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

[Keramatifar]

با سلام و عرض خیر مقدم خدمت برنامه نویسان و برنامه نویسان بعد از این :wink: ...
در این بخش میخوایم در مورد مسائل و نکاتی از برنامه نویسی کاربردی بحث کنیم، مواردی که بعد از رسم تمامی دیاگرام ها و فلوچارتهای برنامه به آنها میرسیم و مثل ... میمونیم تو گل
امیدوارم دوستان دیگر هم اگه نکاتی دارن که به درد بقیه هم میخوره حتماً در اینجا مطرح کنن ... .


-- با اجازه آقا محمد --
hr110 : آدرس نکات برنامه نویسی درون این پست به این شرح می‌باشند:

باز و بسته کردن سیدی درایو (http://barnamenevis.org/forum/showpost.php?p=45449&postcount=3)
تغییر Volume ویندوز (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=4)
چگونه لیست سیدی درایوهای کامپیوتر را بدست آوریم (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=5)
تغییر Resolution مونیتور (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=6)
قرار دادن یک Bitmap در یک متافایل (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=7)
بدست آوردن Serial Number درایو (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=8)
از بین بردن یک Task در ویندوز (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=9)
شناسایی یک فایل (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=10)
کلیه اعمال قابل انجام روی فلاپی دیسک (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=11)
دیالوگ برای Select Directory (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=13)
روش چرخاندن یک نقطه در فضای دو بعدی حول یک نقطه دوبعدی دیگر: (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=14)
Screen Shots (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=15)
محاسبه سن یک فرد (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=16)
محاسبه لگاریتم با پایه متغیر (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=17)
ضرب اعداد صحیح بزرگ (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=18)
استفاده از الگوریتم Base64 جهت Encoding و Decoding (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=19)
محاسبه فاکتوریل یک عدد (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=20)
محاسبه معکوس یک ماتریس (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=21)
تعیین اول بودن یک عدد (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=22)
تغییر مبنای یک عدد از مبنای هشت به Integer (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=23)
تغییر مبنای یک عدد Integer به مبنای هشت (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=24)
تعیین شماره روز در سال (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=25)
تبدیل یک عدد هگزادسیمال به باینری (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=26)
تغییر مقیاس یک تصویر (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=27)
رندر متن یک TrichEdit در یک Canvas (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=28)
تغییر وضوح یک Jpg (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=29)
اعمال فیلتر Emboss روی یک تصویر (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=30)
highlight کردن متن درون Twebbrowser (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=31)
بدست آوردن پروسسهای فعال شبکه (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=32)
ایجاد یک TWebBrowser در RunTime (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=33)
استفاده از ClientSocket و ServerSocket (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=34)
بدست آوردن لیست کاربران موجود در شبکه Remote (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=35)
چاپ یک صفحه در TwebBrowser (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=36)
انتخاب یک کامپیوتر در شبکه (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=37)
لود کردن یک کد html بصورت مستقیم در TWebBrowser (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=38)
ارسال پیام در ICQ (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=39)
تبدیل یک فایل CSV به XML (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=40)
لیست تمام فایلهای موجود در یک دایرکتوری (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=41)
نصب یک فایل INF در دلفی (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=42)
دسترسی به ListBox از طریق API (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=43)
لیست تمام زیرپوشه های یک پوشه اصلی (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=44)
جایگزینی یک متن درون TextFile (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=45)
تغییر نام یک دایرکتوری (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=46)
خواندن یک فایل table-textfile درون یک StringGrid (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=47)
استفاده از توابع shell برای copy/move یک فایل (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=48)
اضافه کردن اطلاعات به یک فایل EXE (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=49)
پاک کردن یک فایل درون پوشه Document (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=50)
توابع مفید جهت کار با Stream (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=51)
تبدیل OEM به ANSI (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=52)
ثبت خروجی یک برنامه DOS (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=53)
قرار دادن یک فایل Exe درون برنامه و اجرای آن (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=54)
پاک کردن برنامه توسط خودش بعد از اجرای آن (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=55)
غیر فعال کردن دکمه Close در فرم (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=56)
روش استفاده از TFileStream (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=57)
جایگزینی یک Dll در حال استفاده از آن (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=58)
تغییر صفات یک فایل (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=59)
خواندن یک فایل متنی بصورت خط به خط و تغییر آن (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=60)
تعیین فضای آزاد دیسک (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=61)
استفاده از فایلهای INI (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=62)
سایز یک دایرکتوری (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=63)
کپی کردن یک فایل (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=64)
روش بدست آوردن اطلاعات CPU (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=65)
مشخص کردن وجود Terminal Service ها (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=66)
کپی فایلهای دایرکتوری (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=67)
تعیین نسخه MS Word نصب شده روی کامپیوتر (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=68)
وارد کردن یک متن RTF در Word (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=69)
فشرده سازی و ترمیم یک بانک اطلاعاتی Access (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=70)
ایجاد Database در یک بانک اطلاعاتی sql sever 2000 در حالت local (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=71)
پیدا کردن یک مقدار در فیلد ایندکس نشده به کمک TTable (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=72)
تهیه خروجی از جداول ADO به فرمتهای مختلف (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=73)
ایجاد خروجی از TDBGrid به قالب Excel (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=74)
دسترسی به جداول paradox روی cdrom یا درایوهای Read Only (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=75)
ایجاد یک جدول مجازی (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=76)
ایجاد سریع یک جدول پارادوکس به کمک کد (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=77)
ایجاد یک اتصال DBExpress در زمان اجرا (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=78)
رنگ آمیزی یک TDBGrid (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=79)
خواندن تمام رکوردهای یک جدول در TstringGrid (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=80)
جلوگیری از لیست توماری شدن منو (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=82)
به چرخش در آوردن متن (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=83)
یافتن فایل در تمام شاخه و زیر شاخه هایش (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=84)
بدست آوردن Handle یک پروسه با نام فایلش (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=85)
فرم شفاف شده و فقط کنترل ها نشان داده شود (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=86)
مخفی و ظاهر ساختن عنوان فرم (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=87)
خذف یا انتقال فایل در حال اجرا توسط برنامه دیگر ( فقط در ویندوز نوع NT) (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=88)
تعیین وضعیت مانیتور (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=89)
طریقه بوت کردن ویندوز 2000 و XP (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=90)
چگونه میتوان پنجره اضافه کردن چاپگر را نمایش داد (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=91)
چگونه میتوان کنترل صفحه کلید را در تمامی ویندوزها بدست گرفت (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=92)
کد خطا های زمان اجرای دلفی (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=93)
نشان دادن تمام گزینه های منو در روی دکمه برنامه در Taskbar (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=94)
زمان آخرین دسترسی به یک فایل (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=95)
فهمیدن اینکه آیا یک ایمیل از نظر املایی درست است یا نه (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=96)
حذف داده های تکراری از لیست (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=97)
ساده ترین راه برای باز کردن یک فایل توسط برنامه مرتبط با آن (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=98)
ایجاد سایه در زیر فرم ها (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=99)
پیدا کردن یک پروسه در پروسه های دیگر با نام فایلش (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=100)
تقریبا کلیه فانکشن هایی که برای کار با فلاپی نیاز میشه ... (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=101)
بدست آوردن پسورد فایلهای اکسس 97 (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=102)
تشخیص نصب بودن یا نبودن کارت صدا ... (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=103)
بدست آوردن و تنظیم کردن صدا در سیستم (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=104)
چگونه دکمه Caps Lock را روشن و خاموش کنیم (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=105)
چگونه می توان از جابجایی فرم جلوگیری کرد (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=106)
چگونه می توان RecycleBin را خالی کرد (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=107)
فرمت کردن یک دریاو در win32 (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=108)
عوض کردن wallpaper (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=109)
این یه کد برای نوشتن یک عدد به حروف (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=110)
ذخیره کردن یک فرم به عنوان یک عکس (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=112)
Drop Dawn کردن آیتم های لیست باکس (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=113)
گذاشتن هرگونه عکس بر روی BitBtn ... (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=114)
نمایش صفحه مشخصات یک فایل ( Properties ) ... (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=115)
مشخص نمودن وضعیت اتصال به اینترنت (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=116)
بدت آوردن نام کاربر (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=117)
Extract an Icon from EXE or DLL file (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=118)
این تابع برنامه مورد نظر را اجر میکند و تا زمان خاتمه آن منتظر میماند. (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=119)
روشن و خاموش کردن Numlock (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=120)
نمایش سطرهای یک Grid به صورت یکی در میان (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=121)
چگونه سایز Col را در یک DBGrid به صورت اتوماتیک قرار دهیم (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=123)
اضافه نمودن یک کاربر جدید داخل یک دیتابیس در SQLServer 2000 (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=124)
کنترل ولوم صدا با استفاده از کد نویسی (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=125)
نحوه استفاده بررسی خالی بودن کنترل TImage (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=126)
رنگ آمیزی کنترلهای تمکرز یافته(Focused Control) (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=127)
CheckBox در DBGrid (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=130)
تبدیل عدد به حرف (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=134)
نشان دادن فرم بدون دکمه ای در تسکبار (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=135)
تشخیص اتصال به شبکه (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=138)
چه مدت است که ویندوز شما در حال اجراست (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=139)
ایجاد میانبر از یک فایل در ویندوز (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=140)
minimize کردن کلیه پنجره ها (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=141)
تغییر تاریخ سیستم (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=142)
نمایش مجموع مقادیر در DbGrid (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=143)
تغییر Resolution مونیتور (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=144)
shutdown and restart and logof windows (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=145)
تصویر توسعه‌دهندگان دلفی 7 (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=147)
تعریف آرایه های ثابت (Constant) در Delphi (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=157)
دو کد نمونه برای کار با آرایه هایی از کامپوننتها (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=158)
بر زدن (Shuffle) آرایه (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=159)
تشخیص اتصال (connection) به اینترنت (internet) (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=163)
دانلود (download) فایل از اینترنت با نمایش درصد پیشرفت (progress indicator) (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=164)
خواندن (Get) لیست favorites از IE (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=165)
تغییر صفحه Home Page در IE (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=166)
بدست آوردن لیست NetWork Drive ها (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=167)
تعیین screen saver (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=169)
تعیین زمان در حال اجرا بودن windows (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=170)
تشخیص Administrator بودن کاربر (user) (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=171)
تبدیل RGB به CMYK (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=172)
یافتن MyDouments برای کاربر جاری (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=173)
Cool how Can I Read a unicode text file in Delphi (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=174)
تغییر اندازه کلید Start (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=175)
چک کردن اینکه آیا فایل در Local Drive می باشد. (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=176)
چک کردن اینکه پارتیشن Fat میباشد یا NTFS (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=177)
چک کردن اینکه آیا سرویسی مورد نظر start می باشد (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=178)
چک کردن اینکه آیا Sound card نصب شده است (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=179)
چک کردن اینکه آیا دلفی در حال اجراست (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=180)
پیدا کردن و بارگذاری Icon داخل فایل (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=181)
با این تابع می توانید ولوم سریالِ دیسک را بدست آوردید (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=182)
چگونه Edit فقط عدد بگیرد (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=183)
چگونه برنامه مان فقط یک نسخه اجرا شود (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=184)
تغییر رزولوشن مانیتور (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=185)
خالی کردن Editهای یک فرم (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=186)
چک کردن خالی بودن یک مسیر (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=187)
آیا فایل مورد نظر باینری است یا نوشتاری است (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=188)
چگونه فایلهای INI را نصب کنی (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=189)
چگونه تعداد ایتمها ی ListBox را با API بدست اوریم (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=190)
چگونه یک ایتم ListBox را با API حذف کنی (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=191)
چگونه ایتم انتخاب شده ی ListBox را توسط API بدست اوریم (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=192)
گرفتن ایتم یک ایتم ListBox توسط API (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=193)
بدست اوردن تمامی ایتم های یک ListBox توسط API (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=194)
تغییر نام یک پوشه (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=195)
باز کردن یک پوشه توسط Windows Explorer (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=196)
بدست اوردن مالک ( Owner ) یک فای (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=197)
مقایسه ی اندازه ی دو فایل (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=198)
بدست اوردن تاریخ یک فایل (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=199)
ایا فایل ما ASCII است (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=200)
بدست اوردن حجم یک فایل (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=201)
کپی کردن یک پوشه (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=202)
جا به جا کردن یک پوشه (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=203)
حذف یک پوشه (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=204)
گرفتن مسیر جاری و تغییر مسیر جاری (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=205)
کپی کردن فایل (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=206)
خواندن Version Info یک فایل (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=207)
ریختن یک فایل در سطل زباله ویندوز ... (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=208)

[مهدی کرامتی]

سلام.

آقا محمد، به جامعه برنامه نویس خوش آمدی.

در ضمن، اگر میخواهی مطلب بنویسی یادت باشه که توضیحات انگلیسی‌اش رو هم حتما ترجمه کنی.

[Keramatifar]

با استفاده از این فانکشن میتونید در هر نوع سیدی درایوی رو باز و بسته کنید
در اثر فشارهای مکرر دوستان من ترجمه فارسی توضیحات رو هم به کدها اضافه کردم



uses
MMSystem;

procedure TForm1.Button1Click(Sender: TObject);
begin
{/باز کردن سیدی رام: در صورت موفقیت 0 برمیگرداند/}
{/ open CD-ROM drive; returns 0 if successfull /}
mciSendString('set cdaudio door open wait', nil, 0, handle);

{/ close the CD-ROM drive; returns 0 if successfull /}
{/بستن سیدی رام: در صورت موفقیت 0 برمیگرداند/}
mciSendString('set cdaudio door closed wait', nil, 0, handle);
end;



اینجانب بدینوسیله آمادگی پذیرش هر نوع انتقاد، راهنمایی و پیشنهاد را اعلام میدارم ...

[Keramatifar]

تغییر Volume ویندوز

یک TrackBar در فرم خود قرار دهید و Max value را به 15 تغییر دهید و در رویداد OnChange آن کد زیر را قرار دهید:

procedure TForm1.TrackBar1Change(Sender: TObject);
var
Count, i: integer;
begin
Count := waveOutGetNumDevs;
for i := 0 to Count do
begin
waveOutSetVolume(i,longint(TrackBar1.Posit ion*4369)*65536+longint(TrackBar1.Position *4369));
end;
end;
و با TrackBar بازی کنید ...

[Keramatifar]

به دست آوردن لیست سیدی درایوهای متصل به کامپیوتر
یک فانشکن مینویسیم که یک استرینگ بر میگرداند

Function GetCDList : String;
Var
I : Integer;
Drives: Integer;
Tmp : String;
begin
Drives := GetLogicalDrives;
Result := '';
// units A=0 to el Z=25
For I := 0 To 25 Do
If (((1 Shl I) And Drives)<>0) Then
Begin
Tmp := Char(65+I)+':\';
If (GetDriveType(PChar(Tmp))=DRIV E_CDROM) Then
Result := Result+Char(65+I);
End;
End;
نتیجه یک استرینگ است که لیست سیدی درایوها را بترتیب نشان میدهد[/b]

[Keramatifar]

تغییر Resolution مونیتور

باید یک پروسیجر به شکل زیر بنویسیم:

procedure SetResolution(ResX, ResY: DWord);
var
lDeviceMode : TDeviceMode;
begin
EnumDisplaySettings(nil, 0, lDeviceMode);
lDeviceMode.dmFields:=DM_PELSWIDTH or DM_PELSHEIGHT;
lDeviceMode.dmPelsWidth :=ResX;
lDeviceMode.dmPelsHeight:=ResY;
ChangeDisplaySettings(lDeviceMode, 0);
end;
نکته بسیار مهم:

اگر اعداد غیر استاندارد برای Resolutoin مونیتور وارد کنید احتمال آسیب رسیدن به مونیتور وجود دارد، از رزولوشن های استاندارد مثل 320*240 ، 640*480 ، 1024*768 و ... استفاده کنید

[Keramatifar]

قرار دادن یک Bitmap در یک متافایل

procedure TForm1.Button1Click(Sender: TObject);
var
m : TmetaFile;
mc : TmetaFileCanvas;
b : tbitmap;
begin
m := TMetaFile.Create;
b := TBitmap.create;
b.LoadFromFile('C:\SomePath\SomeBitmap.BMP ');
m.Height := b.Height;
m.Width := b.Width;
mc := TMetafileCanvas.Create(m, 0);
mc.Draw(0, 0, b);
mc.Free;
b.Free;
m.SaveToFile('C:\SomePath\Test.emf');
m.Free;
Image1.Picture.LoadFromFile('C:\SomePath\Test.emf' );
end;

[Keramatifar]

بدست آوردن Serial Number درایو

procedure TForm1.Button1Click(Sender: TObject);
var
VolumeName,
FileSystemName : array [0..MAX_PATH-1] of Char;
VolumeSerialNo : DWord;
MaxComponentLength,
FileSystemFlags : Integer;
begin
GetVolumeInformation('C:\',VolumeName,MAX_ PATH,@VolumeSerialNo,
MaxComponentLength,FileSystemFlags,
FileSystemName,MAX_PATH);
Memo1.Lines.Add('VName = '+VolumeName);
Memo1.Lines.Add('SerialNo = $'+IntToHex(VolumeSerialNo,8));
Memo1.Lines.Add('CompLen = '+IntToStr(MaxComponentLength));
Memo1.Lines.Add('Flags = $'+IntToHex(FileSystemFlags,4));
Memo1.Lines.Add('FSName = '+FileSystemName);
end;

[Keramatifar]

از بین بردن یک Task در ویندوز
با استفاده از این فانکشن کوچولو میتونید هر نوع برنامه اجرا شده ای رو که پسوند .Exe دارد، از لیست Task Manager ویندوز پاک کنید
مثلا:
KillTask('notepad.exe');
KillTask('iexplore.exe'); /}


uses
Tlhelp32, Windows, SysUtils;

function KillTask(ExeFileName: string): integer;
const
PROCESS_TERMINATE=$0001;
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
begin
result := 0;

FSnapshotHandle := CreateToolhelp32Snapshot
(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := Sizeof(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle,
FProcessEntry32);

while integer(ContinueLoop) <> 0 do
begin
if ((UpperCase(ExtractFileName(FProce ssEntry32.szExeFile)) =
UpperCase(ExeFileName))
or (UpperCase(FProcessEntry32.szExeFile&#4 1; =
UpperCase(ExeFileName))) then
Result := Integer(TerminateProcess(OpenProcess(
PROCESS_TERMINATE, BOOL(0),
FProcessEntry32.th32ProcessID), 0));
ContinueLoop := Process32Next(FSnapshotHandle,
FProcessEntry32);
end;

CloseHandle(FSnapshotHandle);
end;

[Keramatifar]

شناسایی یک فایل

function GetCheckSum (FileName : string) : DWORD;
var
F : File of DWORD;
Fsize : DWORD;
Buffer : Array [0..500] of DWORD;
P : Pointer;
begin
FileMode := 0;
AssignFile ( F , FileName);
Reset ( F );
Seek ( F , FileSize ( F ) div 2);
Fsize := FileSize( F )-1-FilePos( F );
if Fsize > 500 then Fsize := 500;
BlockRead ( F, Buffer, Fsize);
Close ( F );
P:=@Buffer;
asm
xor eax, eax
xor ecx, ecx
mov edi , p
@again:
add eax, [edi + 4*ecx]
inc ecx
cmp ecx, fsize
jl @again
mov @result, eax
end;
end;

[Keramatifar]

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

================================================== ===========
unit lDrives;
interface
uses Forms, Messages, Classes, WinProcs, WinTypes, SysUtils,
Dialogs, Controls;

const
MsgAskDefault = 'Please insert a disk on drive %s:';
MsgWProtected = 'Error: The disk %s is write-protected.';

type
TDriveType = (dtAll,dtFixed,dtRemovable,dtRemote{/$IFDE F WIN32/},dtCDRom,dtRamDisk{/$ENDIF/}&#4 1;;

function ComposeFileName (Dir,Name:string):string;
function HasDiskSpace({/$IFDEF WIN32/}Drive: string{/$ELSE/}Drive: char{/$ENDIF/}; MinRequired: LongInt): boolean;
function GetDirectorySize(const Path: string): LongInt;
function GetFileSizeByName(const Filename: string): longInt;
function IsDiskRemovable(Drive: char): boolean;
function IsDiskInDrive(Drive: char): boolean;
function IsDiskWriteProtected(Drive: char): boolean;
function AskForDisk(Drive: char; Msg: string; CheckWriteProtected: boolean): boolean;
procedure GetAvailableDrives(DriveType: TDriveType; Items: TStrings);

implementation

function ComposeFileName (Dir,Name:string):string;
var
Separator: string[1];
begin
if (length(Dir) > 0) and (Dir[length(Dir)]='\') then
delete(Dir, length(Dir), 1);
if (length(Name) > 0) and (Name[1]='\') then
delete(Name, 1, 1);
if Name='' then Separator:='' else Separator:='\';
result:=format('%s%s%s',[Dir,Separator ,Name]);
end;

function HasDiskSpace(Drive: {/$IFDEF WIN32/}string{/$ELSE/}char{/$ENDIF /}; MinRequired: LongInt): boolean;
begin
if Drive='' then Drive:='C';
{/$IFDEF WIN32/}
result:=((GetDriveType(PChar(D rive))<>0) and
(SysUtils.DiskFree(Ord(UpCase(Driv e[1]))-$40)=-1) or
(SysUtils.DiskFree(Ord(UpCase(Driv e[1]))-$40)>=MinRequired));
{/$ELSE/}
result:=((GetDriveType(Ord(UpC ase(Drive))-$40)<>0) and
(DiskFree(Ord(UpCase(Drive)&#4 1;-$40)=-1) or
(DiskFree(Ord(UpCase(Drive)&#4 1;-$40)>=MinRequired));
{/$ENDIF/}
end;

function GetDirectorySize(const Path: string): LongInt;
var
S: TSearchRec;
TotalSize: LongInt;
begin
TotalSize:=0;
if FindFirst(ComposeFileName(Path,'*.*'), faAnyFile, S)=0 then
repeat
Inc(TotalSize, S.Size);
until FindNext(S)<>0;
result:=TotalSize;
end;

function GetFileSizeByName(const Filename: string): longInt;
var
F: File;
begin
AssignFile(F, Filename);
Reset(F,1);
result:=FileSize(F);
CloseFile(F);
end;

function IsDiskRemovable(Drive: char): boolean;
begin
{/$IFDEF WIN32/}
result:=GetDriveType(PChar(Drive+'&#58 ;\'))=DRIVE_REMOVABLE;
{/$ELSE/}
result:=GetDriveType(ord(UpCase(Dr ive))-65)=DRIVE_REMOVABLE;
{/$ENDIF/}
end;

function IsDiskInDrive(Drive: char): Boolean;
var
ErrorMode: word;
begin
Drive:=Upcase(Drive);
if not (Drive in ['A'..'Z']) then
begin
Result:=False;
Exit;
end;
ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try
if DiskSize(Ord(Drive) - 64) = -1 then
Result := False
else
Result := True;
finally
SetErrorMode(ErrorMode);
end;
end;

function IsDiskWriteProtected(Drive: char): Boolean;
var
F: File;
ErrorMode: Word;
begin
ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
AssignFile(F,Drive+':\_$.$$$');
try
try
Rewrite(F);
CloseFile(F);
Erase(F);
Result:=False;
except
Result:=True;
end;
finally
SetErrorMode(ErrorMode);
end;
end;

{/$IFDEF WIN32/}
procedure GetAvailableDrives(DriveType: TDriveType; Items: TStrings);
var
Drive: Integer;
DriveLetter: string;
begin
Items.Clear;
for Drive := 0 to 25 do
begin
DriveLetter := Chr(Drive + ord('A'))+':\';
case DriveType of
dtAll : if GetDriveType(PChar(DriveLetter)) in [DRIVE_REMOVABLE,DRIVE_FIXED,DRIVE_REMOTE,
DRIVE_CDROM,DRIVE_RAMDISK] then
Items.Add(DriveLetter);
dtRemovable: if GetDriveType(PChar(DriveLetter))=D RIVE_REMOVABLE then
Items.Add(DriveLetter);
dtFixed : if GetDriveType(PChar(DriveLetter))=D RIVE_FIXED then
Items.Add(DriveLetter);
dtRemote : if GetDriveType(PChar(DriveLetter))=D RIVE_REMOTE then
Items.Add(DriveLetter);
dtCDRom : if GetDriveType(PChar(DriveLetter))=D RIVE_CDROM then
Items.Add(DriveLetter);
dtRamDisk : if GetDriveType(PChar(DriveLetter))=D RIVE_RAMDISK then
Items.Add(DriveLetter);
end;
end;
end;
{/$ELSE/}
procedure GetAvailableDrives(DriveType: TDriveType; Items: TStrings);
var
Drive: Integer;
DriveLetter: char;
begin
Items.Clear;
for Drive := 0 to 25 do
begin
DriveLetter := Chr(Drive + ord('A'));
case DriveType of
dtAll : if GetDriveType(Drive) in [DRIVE_REMOVABLE,DRIVE_FIXED,DRIVE_REMOTE&# 93; then
Items.Add(DriveLetter+':\');
dtRemovable: if GetDriveType(Drive)=DRIVE_REMOVABLE then
Items.Add(DriveLetter+':\');
dtFixed : if GetDriveType(Drive)=DRIVE_FIXED then
Items.Add(DriveLetter+':\');
dtRemote : if GetDriveType(Drive)=DRIVE_REMOTE then
Items.Add(DriveLetter+':\');
end;
end;
end;
{/$ENDIF/}

function AskForDisk(Drive: char; Msg: string; CheckWriteProtected: boolean): boolean;
var
Ready : boolean;
begin
Ready:=false; Result:=false;
if Msg='' then Msg:=Format(MsgAskDefault,[Drive]& #41;;
while not(Ready) do
try
if IsDiskRemovable(Drive) then
case MessageDlg(Msg, mtConfirmation, [mbOk,mbCancel],0) of
mrOk : ready:=IsDiskInDrive(Drive);
mrCancel: exit;
end
else
Ready:=true;
except
result:=false;
exit;
end;
ready:=false;
while not(Ready) do
try
if CheckWriteProtected and IsDiskWriteProtected(Drive) then
begin
ready:=false;
if MessageDlg(Format(MsgWProtected,[Upcas e(Drive)+':']),mtError,[mb Retry,mbCancel],0)=mrCancel then
exit;
end
else
ready:=true;
except
result:=false;
exit;
end;
result:=Ready;
end;

end.

[Keramatifar]

اضافه کردن تکست به Log Files
function AddTextToFile(const aFileName, aText: string; AddCRLF: Boolean): Boolean;
var
lF: Integer;
lS: string;
begin
Result := False;
if FileExists(aFileName) then lF := FileOpen(aFileName, fmOpenWrite + fmShareDenyNone)
else lF := FileCreate(aFileName);
if (lF >= 0) then
try
FileSeek(lF, 0, 2);
if AddCRLF then lS := aText + #13#10
else lS := aText;
FileWrite(lF, lS[1], Length(lS));
finally
FileClose(lF);
end;
end;

[Keramatifar]

دیالوگ برای Select Directory


uses FileCtrl; // for SelectDirectory

var
Dir: string;
(...)
Dir := 'C:\Windows';
if SelectDirectory(Dir, [sdAllowCreate, sdPerformCreate,
sdPrompt], 0) then
Label1.Caption := Dir;

[پسر خاک]

روش چرخاندن یک نقطه در فضای دو بعدی حول یک نقطه دوبعدی دیگر:

const
PIDiv180 = 0.017453292519943295769236907684886;

procedure Rotate(RotAng: Double; x, y, ox, oy: Double; var Nx, Ny: Double);
begin
Rotate(RotAng, x - ox, y - oy, Nx, Ny);
Nx := Nx + ox;
Ny := Ny + oy;
end;
(* End Of Rotate Cartesian Point About Origin *)


procedure Rotate(RotAng: Double; x, y: Double; var Nx, Ny: Double);
var
SinVal: Double;
CosVal: Double;
begin
RotAng := RotAng * PIDiv180;
SinVal := Sin(RotAng);
CosVal := Cos(RotAng);
Nx := x * CosVal - y * SinVal;
Ny := y * CosVal + x * SinVal;
end;

[Keramatifar]

Screen Shots
با استفاده از این کد میتوانید تصویر Screen را در یک فایل Bitmap ذخیره نمائید. اگر نمیخواهید از یک برنامه فعال دلفی استفاده کنید میتوانید یک 'Application.Minimize;' در Beginning پروسیجر وارد کنید.




uses
Windows, Graphics, Forms;

procedure TForm1.Button1Click(Sender: TObject);
var
DC: HDC;
Canvas: TCanvas;
MyBitmap: TBitmap;
begin
Canvas := TCanvas.Create;
MyBitmap := TBitmap.Create;
DC := GetDC(0);

try
Canvas.Handle := DC;
with Screen do
begin
{/ detect the actual height and with of the screen /}
MyBitmap.Width := Width;
MyBitmap.Height := Height;

{/ copy the screen content to the bitmap /}
MyBitmap.Canvas.CopyRect(Rect(0, 0, Width, Height), Canvas,
Rect(0, 0, Width, Height));
{/ stream the bitmap to disk /}
MyBitmap.SaveToFile('c:\windows\desktop\sc reen.bmp');
end;

finally
{/ free memory /}
ReleaseDC(0, DC);
MyBitmap.Free;
Canvas.Free
end;
end;

[پسر خاک]

محاسبه سن یک فرد
function CalculateAge(Birthday, CurrentDate: TDate): Integer;
var
Month, Day, Year, CurrentYear, CurrentMonth, CurrentDay: Word;
begin
DecodeDate(Birthday, Year, Month, Day);
DecodeDate(CurrentDate, CurrentYear, CurrentMonth, CurrentDay);

if (Year = CurrentYear) and (Month = CurrentMonth) and (Day = CurrentDay) then
begin
Result := 0;
end
else
begin
Result := CurrentYear - Year;
if (Month > CurrentMonth) then
Dec(Result)
else
begin
if Month = CurrentMonth then
if (Day > CurrentDay) then
Dec(Result);
end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption := Format('Your age is %d', [CalculateAge(StrToDate('01.01.1903'&# 41;, Date)]);
end;

[پسر خاک]

محاسبه لگاریتم با پایه متغیر
function Log(x, b: Real): Real;
begin
Result := ln(x) / ln(b);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(Format('%f', [Log(10, 10)]));
end;

[پسر خاک]

ضرب اعداد صحیح بزرگ
type
IntNo = record
Low32, Hi32: DWORD;
end;

function Multiply(p, q: DWORD): IntNo;
var
x: IntNo;
begin
asm
MOV EAX,[p]
MUL [q]
MOV [x.Low32],EAX
MOV [x.Hi32],EDX
end;
Result := x
end;



var
r: IntNo;
begin
r := Multiply(40000000, 80000000);
ShowMessage(IntToStr(r.Hi32) + ', ' + IntToStr(r.low32))
end;

[پسر خاک]

استفاده از الگوریتم Base64 جهت Encoding و Decoding
function Decode(const S: AnsiString): AnsiString;
const
Map: array[Char] of Byte = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 62, 0, 0, 0, 63, 52, 53,
54, 55, 56, 57, 58, 59, 60, 61, 0, 0, 0, 0, 0, 0, 0, 0, 1, 2,
3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19,
20, 21, 22, 23, 24, 25, 0, 0, 0, 0, 0, 0, 26, 27, 28, 29, 30,
31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45,
46, 47, 48, 49, 50, 51, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0);
var
I: LongInt;
begin
case Length(S) of
2:
begin
I := Map[S[1]] + (Map[S[2]] shl 6);
SetLength(Result, 1);
Move(I, Result[1], Length(Result))
end;
3:
begin
I := Map[S[1]] + (Map[S[2]] shl 6) + (Map[S[3]] shl 12);
SetLength(Result, 2);
Move(I, Result[1], Length(Result))
end;
4:
begin
I := Map[S[1]] + (Map[S[2]] shl 6) + (Map[S[3]] shl 12) +
(Map[S[4]] shl 18);
SetLength(Result, 3);
Move(I, Result[1], Length(Result))
end
end
end;

function Encode(const S: AnsiString): AnsiString;
const
Map: array[0..63] of Char = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' +
'abcdefghijklmnopqrstuvwxyz0123456789+/';
var
I: LongInt;
begin
I := 0;
Move(S[1], I, Length(S));
case Length(S) of
1:
Result := Map[I mod 64] + Map[(I shr 6) mod 64];
2:
Result := Map[I mod 64] + Map[(I shr 6) mod 64] +
Map[(I shr 12) mod 64];
3:
Result := Map[I mod 64] + Map[(I shr 6) mod 64] +
Map[(I shr 12) mod 64] + Map[(I shr 18) mod 64]
end
end;

[پسر خاک]

محاسبه فاکتوریل یک عدد
function FacIterative(n: Word): Longint;
var
f: LongInt;
i: Integer;
begin
f := 1;
for i := 2 to n do f := f * i;
Result := f;
end;



function FacRecursive(n: Word): LongInt;
begin
if n > 1 then
Result := n * FacRecursive(n-1)
else
Result := 1;
end;

[پسر خاک]

محاسبه معکوس یک ماتریس

type
RCOMat = array of array of Extended;

var
DimMat: integer;

procedure InvertMatrix(var aa: RCOMat);
var
numb, nula1, ipiv, indxr, indxc: array of Integer;
i, j, l, kod, jmax, k, ll, icol, irow: Integer;
amax, d, c, pomos, big, dum, pivinv: Double;
ind: Boolean;
begin
for j := 0 to Pred(DimMat) do ipiv[j] := 0;

irow := 1;
icol := 1;
for i := 0 to Pred(DimMat) do
begin
big := 0;

for j := 0 to Pred(DimMat) do
begin
if (ipiv[j] <> 1) then
begin
for k := 0 to Pred(DimMat) do
begin
if (ipiv[k] = 0) then
if (Abs(aa[j, k]) >= big) then
begin
big := Abs(aa[j, k]);
irow := j;
icol := k;
end
else;
end;
end;
end;

ipiv[icol] := ipiv[icol] + 1;
if (irow <> icol) then
begin
for l := 0 to Pred(DimMat) do
begin
dum := aa[irow, l];
aa[irow, l] := aa[icol, l];
aa[icol, l] := dum;
end;
for l := 0 to Pred(DimMat) do
begin
dum := aa[irow + DimMat + 1, l];
aa[irow + DimMat + 1, l] := aa[icol + DimMat + 1, l];
aa[icol + DimMat + 1, l] := dum;
end;
end;
indxr[i] := irow;
indxc[i] := icol;
if (aa[icol, icol] = 0) then;
pivinv := 1.0 / aa[icol, icol];
aa[icol, icol] := 1.0;
for l := 0 to Pred(DimMat) do aa[icol, l] := aa[icol, l] * pivinv;
for l := 0 to Pred(DimMat) do aa[icol + DimMat + 1, l] :=
aa[icol + DimMat + 1, l] * pivinv;
for ll := 0 to Pred(DimMat) do
begin
if (ll <> icol) then
begin
dum := aa[ll, icol];
aa[ll, icol] := 0.0;
for l := 0 to Pred(DimMat) do aa[ll, l] := aa[ll, l] - aa[icol, l] * dum;
for l := 0 to Pred(DimMat) do aa[ll + DimMat + 1, l] :=
aa[ll + DimMat + 1, l] - aa[icol + DimMat + 1, l] * dum;
end;
end;
end;

for l := Pred(DimMat) downto 0 do
begin
if (indxr[l] <> indxc[l]) then
begin
for k := 0 to Pred(DimMat) do
begin
dum := aa[k, indxr[l]];
aa[k, indxr[l]] := aa[k, indxc[l]];
aa[k, indxc[l]] := dum;
end;
end;
end;
end;

[پسر خاک]

تعیین اول بودن یک عدد

unction IsPrime(N: Cardinal): Boolean; register;
// test if N is prime, do some small Strong Pseudo Prime test in certain bounds
// copyright (c) 2000 Hagen Reddmann, don't remove
asm
TEST EAX,1 {/ Odd(N) ?? /}
JNZ @@1
CMP EAX,2 {/ N == 2 ?? /}
SETE AL
RET
@@1: CMP EAX,73 {/ N JB @@C /}
JE @@E {/ N == 73 ?? /}
PUSH ESI
PUSH EDI
PUSH EBX
PUSH EBP
PUSH EAX {/ save N as Param for @@5 /}
LEA EBP,[EAX - 1] {/ M == N -1, Exponent /}
MOV ECX,32 {/ calc remaining Bits of M and shift M' /}
MOV ESI,EBP
@@2: DEC ECX
SHL ESI,1
JNC @@2
PUSH ECX {/ save Bits as Param for @@5 /}
PUSH ESI {/ save M' as Param for @@5 /}
CMP EAX,08A8D7Fh {/ N = 9080191 ?? /}
JAE @@3
// now if (N MOV EAX,31
CALL @@5 {/ 31^((N-1)(2^s)) mod N /}
JC @@4
MOV EAX,73 {/ 73^((N-1)(2^s)) mod N /}
PUSH OFFSET @@4
JMP @@5
// now if (N @@3: MOV EAX,2
CALL @@5
JC @@4
MOV EAX,7
CALL @@5
JC @@4
MOV EAX,61
CALL @@5
@@4: SETNC AL
ADD ESP,4 * 3
POP EBP
POP EBX
POP EDI
POP ESI
RET
// do a Strong Pseudo Prime Test
@@5: MOV EBX,[ESP + 12] {/ N on stack /}
MOV ECX,[ESP + 8] {/ remaining Bits /}
MOV ESI,[ESP + 4] {/ M' /}
MOV EDI,EAX {/ T = b, temp. Base /}
@@6: DEC ECX
MUL EAX
DIV EBX
MOV EAX,EDX
SHL ESI,1
JNC @@7
MUL EDI
DIV EBX
AND ESI,ESI
MOV EAX,EDX
@@7: JNZ @@6
CMP EAX,1 {/ b^((N -1)(2^s)) mod N == 1 mod N ?? /}
JE @@A
@@8: CMP EAX,EBP {/ b^((N -1)(2^s)) mod N == -1 mod N ?? , EBP = N -1 /}
JE @@A
DEC ECX {/ second part to 2^s /}
JNG @@9
MUL EAX
DIV EBX
CMP EDX,1
MOV EAX,EDX
JNE @@8
@@9: STC
@@A: RET
@@B: DB 3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67 ,71
@@C: MOV EDX,OFFSET @@B
MOV ECX,18
@@D: CMP AL,[EDX + ECX]
JE @@E
DEC ECX
JNL @@D
@@E: SETE AL
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if IsPrime(3453451) then
ShowMessage('yes');
end;

{/**** Another function ***/}

function IsPrime(Prim: Longint): Boolean;
var
Z: Real;
Max: LongInt;
Divisor: LongInt;
begin
Prime := False;
if (Prim and 1) = 0 then Exit;
Z := Sqrt(Prim);
Max := Trunc(Z) + 1;
Divisor := 3;
while Max > Divisor do
begin
if (Prim mod Divisor) = 0 then Exit;
Inc(Divisor, 2);
if (Prim mod Divisor) = 0 then Exit;
Inc(Divisor, 4);
end;
Prime := True;
end;

[پسر خاک]

تغییر مبنای یک عدد از مبنای هشت به Integer
function OctToInt(Value: string): Longint;
var
i: Integer;
int: Integer;
begin
int := 0;
for i := 1 to Length(Value) do
begin
int := int * 8 + StrToInt(Copy(Value, i, 1));
end;
Result := int;
end;

[پسر خاک]

تغییر مبنای یک عدد Integer به مبنای هشت
function IntToOct(Value: Longint; digits: Integer): string;
var
rest: Longint;
oct: string;
i: Integer;
begin
oct := '';
while Value <> 0 do
begin
rest := Value mod 8;
Value := Value div 8;
oct := IntToStr(rest) + oct;
end;
for i := Length(oct) + 1 to digits do
oct := '0' + oct;
Result := oct;
end;

[پسر خاک]

تعیین شماره روز در سال
function GetDays(ADate: TDate): Extended;
var
FirstOfYear: TDateTime;
begin
FirstOfYear := EncodeDate(StrToInt(FormatDateTime('yy yy', now)) - 1, 12, 31);
Result := ADate - FirstOfYear;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := 'Today is the ' + FloatToStr(GetDays(Date)) + '. day of the year';
end;

[پسر خاک]

تبدیل یک عدد هگزادسیمال به باینری
function HexToBin(Hexadecimal: string): string;
const
BCD: array [0..15] of string =
('0000', '0001', '0010', '0011', '0100', '0101', '0110', '0111',
'1000', '1001', '1010', '1011', '1100', '1101', '1110', '1111');
var
i: integer;
begin
for i := Length(Hexadecimal) downto 1 do
Result := BCD[StrToInt('$' + Hexadecimal[i])] + Result;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(HexToBin('FFA1'));
// Returns 1111111110100001
end;

[پسر خاک]

تغییر مقیاس یک تصویر

[code].... /}

private
function ScalePercentBmp(bitmp: TBitmap; iPercent: Integer): Boolean;

{/ .... /}

function TForm1.ScalePercentBmp(bitmp: TBitmap;
iPercent: Integer): Boolean;
var
TmpBmp: TBitmap;
ARect: TRect;
h, w: Real;
hi, wi: Integer;
begin
Result := False;
try
TmpBmp := TBitmap.Create;
try
h := bitmp.Height * (iPercent / 100);
w := bitmp.Width * (iPercent / 100);
hi := StrToInt(FormatFloat('#', h)) + bitmp.Height;
wi := StrToInt(FormatFloat('#', w)) + bitmp.Width;
TmpBmp.Width := wi;
TmpBmp.Height := hi;
ARect := Rect(0, 0, wi, hi);
TmpBmp.Canvas.StretchDraw(ARect, Bitmp);
bitmp.Assign(TmpBmp);
finally
TmpBmp.Free;
end;
Result := True;
except
Result := False;
end;
end;


// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
ScalePercentBmp(Image1.Picture.Bitmap, 33);
end;

[پسر خاک]

رندر متن یک TrichEdit در یک Canvas
procedure RichEditToCanvas(RichEdit: TRichEdit; Canvas: TCanvas; PixelsPerInch: Integer);
var
ImageCanvas: TCanvas;
fmt: TFormatRange;
begin
ImageCanvas := Canvas;
with fmt do
begin
hdc:= ImageCanvas.Handle;
hdcTarget:= hdc;
// rect needs to be specified in twips (1/1440 inch) as unit
rc:= Rect(0, 0,
ImageCanvas.ClipRect.Right * 1440 div PixelsPerInch,
ImageCanvas.ClipRect.Bottom * 1440 div PixelsPerInch
);
rcPage:= rc;
chrg.cpMin := 0;
chrg.cpMax := RichEdit.GetTextLen;
end;
SetBkMode(ImageCanvas.Handle, TRANSPARENT);
RichEdit.Perform(EM_FORMATRANGE, 1, Integer(@fmt));
// next call frees some cached data
RichEdit.Perform(EM_FORMATRANGE, 0, 0);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
RichEditToCanvas(RichEdit1, Image1.Canvas, Self.PixelsPerInch);
Image1.Refresh;
end;

[پسر خاک]

تغییر وضوح یک Jpg
procedure GetResJpg(JPGFile: string);
const
BufferSize = 50;
var
Buffer: string;
Index: integer;
FileStream: TFileStream;
HorzRes, VertRes: Word;
DP: Byte;
Measure: string;
begin
FileStream := TFileStream.Create(JPGFile,
fmOpenReadWrite);
try
SetLength(Buffer, BufferSize);
FileStream.Read(buffer[1], BufferSize);
Index := Pos('JFIF' + #$00, buffer);
if Index > 0 then
begin
FileStream.Seek(Index + 6, soFromBeginning);
FileStream.Read(DP, 1);
case DP of
1: Measure := 'DPI'; //Dots Per Inch
2: Measure := 'DPC'; //Dots Per Cm.
end;
FileStream.Read(HorzRes, 2); // x axis
HorzRes := Swap(HorzRes);
FileStream.Read(VertRes, 2); // y axis
VertRes := Swap(VertRes);
end
finally
FileStream.Free;
end;
end;

procedure SetResJpg(name: string; dpix, dpiy: Integer);
const
BufferSize = 50;
DPI = 1; //inch
DPC = 2; //cm
var
Buffer: string;
index: INTEGER;
FileStream: TFileStream;
xResolution: WORD;
yResolution: WORD;
_type: Byte;
begin
FileStream := TFileStream.Create(name,
fmOpenReadWrite);
try
SetLength(Buffer, BufferSize);
FileStream.Read(buffer[1], BufferSize);
index := POS('JFIF' + #$00, buffer);
if index > 0
then begin
FileStream.Seek(index + 6, soFromBeginning);
_type := DPI;
FileStream.write(_type, 1);
xresolution := swap(dpix);
FileStream.write(xresolution, 2);
yresolution := swap(dpiy);
FileStream.write(yresolution, 2);
end
finally
FileStream.Free;
end;
end;

[پسر خاک]

اعمال فیلتر Emboss روی یک تصویر
procedure Emboss(ABitmap : TBitmap; AMount : Integer);
var
x, y, i : integer;
p1, p2: PByteArray;
begin
for i := 0 to AMount do
begin
for y := 0 to ABitmap.Height-2 do
begin
p1 := ABitmap.ScanLine[y];
p2 := ABitmap.ScanLine[y+1];
for x := 0 to ABitmap.Width do
begin
p1[x*3] := (p1[x*3]+(p2[(x+3)*3&# 93; xor $FF)) shr 1;
p1[x*3+1] := (p1[x*3+1]+(p2[(x+3)*3 +1] xor $FF)) shr 1;
p1[x*3+2] := (p1[x*3+1]+(p2[(x+3)*3 +1] xor $FF)) shr 1;
end;
end;
end;
end;

[پسر خاک]

highlight کردن متن درون Twebbrowser
{/..../}

private
procedure SearchAndHighlightText(aText: string);

{/..../}

uses mshtml;

{/ .... /}


procedure TForm1.SearchAndHighlightText(aText: string);
var
tr: IHTMLTxtRange; //TextRange Object
begin
if not WebBrowser1.Busy then
begin
tr := ((WebBrowser1.Document as IHTMLDocument2).body as IHTMLBodyElement).createTextRange;
//Get a body with IHTMLDocument2 Interface and then a TextRang obj. with IHTMLBodyElement Intf.

while tr.findText(aText, 1, 0) do //while we have result
begin
tr.pasteHTML('<span style="background-color: Lime; font-weight: bolder;">' +
tr.htmlText + '</span>');
//Set the highlight, now background color will be Lime
tr.scrollIntoView(True);
//When IE find a match, we ask to scroll the window... you dont need this...
end;
end;
end;

// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
SearchAndHighlightText('delphi');
end;

[پسر خاک]

بدست آوردن پروسسهای فعال شبکه
unit PerfInfo;

interface

uses
Windows, SysUtils, Classes;

type
TPerfCounter = record
Counter: Integer;
Value: TLargeInteger;
end;

TPerfCounters = Array of TPerfCounter;

TPerfInstance = class
private
FName: string;
FCounters: TPerfCounters;
public
property Name: string read FName;
property Counters: TPerfCounters read FCounters;
end;

TPerfObject = class
private
FList: TList;
FObjectID: DWORD;
FMachine: string;
function GetCount: Integer;
function GetInstance(Index: Integer): TPerfInstance;
procedure ReadInstances;
public
property ObjectID: DWORD read FObjectID;
property Item[Index: Integer]: TPerfInstance
read GetInstance; default;
property Count: Integer read GetCount;
constructor Create(const AMachine: string; AObjectID: DWORD);
destructor Destroy; override;
end;

procedure GetProcesses(const Machine: string; List: TStrings);

implementation

type
PPerfDataBlock = ^TPerfDataBlock;
TPerfDataBlock = record
Signature: array[0..3] of WCHAR;
LittleEndian: DWORD;
Version: DWORD;
Revision: DWORD;
TotalByteLength: DWORD;
HeaderLength: DWORD;
NumObjectTypes: DWORD;
DefaultObject: Longint;
SystemTime: TSystemTime;
PerfTime: TLargeInteger;
PerfFreq: TLargeInteger;
PerfTime100nSec: TLargeInteger;
SystemNameLength: DWORD;
SystemNameOffset: DWORD;
end;

PPerfObjectType = ^TPerfObjectType;
TPerfObjectType = record
TotalByteLength: DWORD;
DefinitionLength: DWORD;
HeaderLength: DWORD;
ObjectNameTitleIndex: DWORD;
ObjectNameTitle: LPWSTR;
ObjectHelpTitleIndex: DWORD;
ObjectHelpTitle: LPWSTR;
DetailLevel: DWORD;
NumCounters: DWORD;
DefaultCounter: Longint;
NumInstances: Longint;
CodePage: DWORD;
PerfTime: TLargeInteger;
PerfFreq: TLargeInteger;
end;

PPerfCounterDefinition = ^TPerfCounterDefinition;
TPerfCounterDefinition = record
ByteLength: DWORD;
CounterNameTitleIndex: DWORD;
CounterNameTitle: LPWSTR;
CounterHelpTitleIndex: DWORD;
CounterHelpTitle: LPWSTR;
DefaultScale: Longint;
DetailLevel: DWORD;
CounterType: DWORD;
CounterSize: DWORD;
CounterOffset: DWORD;
end;

PPerfInstanceDefinition = ^TPerfInstanceDefinition;
TPerfInstanceDefinition = record
ByteLength: DWORD;
ParentObjectTitleIndex: DWORD;
ParentObjectInstance: DWORD;
UniqueID: Longint;
NameOffset: DWORD;
NameLength: DWORD;
end;

PPerfCounterBlock = ^TPerfCounterBlock;
TPerfCounterBlock = record
ByteLength: DWORD;
end;


{/Navigation helpers/}

function FirstObject(PerfData: PPerfDataBlock): PPerfObjectType;
begin
Result := PPerfObjectType(DWORD(PerfData) + PerfData.HeaderLength);
end;


function NextObject(PerfObj: PPerfObjectType): PPerfObjectType;
begin
Result := PPerfObjectType(DWORD(PerfObj) + PerfObj.TotalByteLength);
end;


function FirstInstance(PerfObj: PPerfObjectType): PPerfInstanceDefinition;
begin
Result := PPerfInstanceDefinition(DWORD(PerfObj) + PerfObj.DefinitionLength);
end;


function NextInstance(PerfInst: PPerfInstanceDefinition): PPerfInstanceDefinition;
var
PerfCntrBlk: PPerfCounterBlock;
begin
PerfCntrBlk := PPerfCounterBlock(DWORD(PerfInst) + PerfInst.ByteLength);
Result := PPerfInstanceDefinition(DWORD(PerfCntrBlk& #41; + PerfCntrBlk.ByteLength);
end;


function FirstCounter(PerfObj: PPerfObjectType): PPerfCounterDefinition;
begin
Result := PPerfCounterDefinition(DWORD(PerfObj) + PerfObj.HeaderLength);
end;


function NextCounter(PerfCntr: PPerfCounterDefinition): PPerfCounterDefinition;
begin
Result := PPerfCounterDefinition(DWORD(PerfCntr) + PerfCntr.ByteLength);
end;


{/Registry helpers/}

function GetPerformanceKey(const Machine: string): HKey;
var
s: string;
begin
Result := 0;
if Length(Machine) = 0 then
Result := HKEY_PERFORMANCE_DATA
else
begin
s := Machine;
if Pos('\\', s) <> 1 then
s := '\\' + s;
if RegConnectRegistry(PChar(s), HKEY_PERFORMANCE_DATA, Result) <> ERROR_SUCCESS then
Result := 0;
end;
end;


{/TPerfObject/}

constructor TPerfObject.Create(const AMachine: string; AObjectID: DWORD);
begin
inherited Create;
FList := TList.Create;
FMachine := AMachine;
FObjectID := AObjectID;
ReadInstances;
end;


destructor TPerfObject.Destroy;
var
i: Integer;
begin
for i := 0 to FList.Count - 1 do
TPerfInstance(FList[i]).Free;
FList.Free;
inherited Destroy;
end;


function TPerfObject.GetCount: Integer;
begin
Result := FList.Count;
end;


function TPerfObject.GetInstance(Index: Integer): TPerfInstance;
begin
Result := FList[Index];
end;


procedure TPerfObject.ReadInstances;
var
PerfData: PPerfDataBlock;
PerfObj: PPerfObjectType;
PerfInst: PPerfInstanceDefinition;
PerfCntr, CurCntr: PPerfCounterDefinition;
PtrToCntr: PPerfCounterBlock;
BufferSize: Integer;
i, j, k: Integer;
pData: PLargeInteger;
Key: HKey;
CurInstance: TPerfInstance;
begin
for i := 0 to FList.Count - 1 do
TPerfInstance(FList[i]).Free;
FList.Clear;
Key := GetPerformanceKey(FMachine);
if Key = 0 then Exit;
PerfData := nil;
try
{/Allocate initial buffer for object information/}
BufferSize := 65536;
GetMem(PerfData, BufferSize);
{/retrieve data/}
while RegQueryValueEx(Key,
PChar(IntToStr(FObjectID)), {/Object name/}
nil, nil, Pointer(PerfData), @BufferSize) = ERROR_MORE_DATA do
begin
{/buffer is too small/}
Inc(BufferSize, 1024);
ReallocMem(PerfData, BufferSize);
end;
RegCloseKey(HKEY_PERFORMANCE_DATA);
{/Get the first object type/}
PerfObj := FirstObject(PerfData);
{/Process all objects/}
for i := 0 to PerfData.NumObjectTypes - 1 do
begin
{/Check for requested object/}
if PerfObj.ObjectNameTitleIndex = FObjectID then
begin
{/Get the first counter/}
PerfCntr := FirstCounter(PerfObj);
if PerfObj.NumInstances > 0 then
begin
{/Get the first instance/}
PerfInst := FirstInstance(PerfObj);
{/Retrieve all instances/}
for k := 0 to PerfObj.NumInstances - 1 do
begin
{/Create entry for instance/}
CurInstance := TPerfInstance.Create;
CurInstance.FName := WideCharToString(PWideChar(DWORD(PerfI nst) +
PerfInst.NameOffset));
FList.Add(CurInstance);
CurCntr := PerfCntr;
{/Retrieve all counters/}
SetLength(CurInstance.FCounters, PerfObj.NumCounters);
for j := 0 to PerfObj.NumCounters - 1 do
begin
PtrToCntr := PPerfCounterBlock(DWORD(PerfInst) + PerfInst.ByteLength);
pData := Pointer(DWORD(PtrToCntr) + CurCntr.CounterOffset);
{/Add counter to array/}
CurInstance.FCounters[j].Counter := CurCntr.CounterNameTitleIndex;
CurInstance.FCounters[j].Value := pData^;
{/Get the next counter/}
CurCntr := NextCounter(CurCntr);
end;
{/Get the next instance./}
PerfInst := NextInstance(PerfInst);
end;
end;
end;
{/Get the next object type/}
PerfObj := NextObject(PerfObj);
end;
finally
{/Release buffer/}
FreeMem(PerfData);
{/Close remote registry handle/}
if Key <> HKEY_PERFORMANCE_DATA then
RegCloseKey(Key);
end;
end;


procedure GetProcesses(const Machine: string; List: TStrings);
var
Processes: TPerfObject;
i, j: Integer;
ProcessID: DWORD;
begin
Processes := nil;
List.Clear;
try
Processes := TPerfObject.Create(Machine, 230); {/230 = Process/}
for i := 0 to Processes.Count - 1 do
{/Find process ID/}
for j := 0 to Length(Processes[i].Counters) - 1 do
if (Processes[i].Counters[j].Coun ter = 784) then
begin
ProcessID := Processes[i].Counters[j].Value;
if ProcessID <> 0 then
List.AddObject(Processes[i].Name, Pointer(ProcessID));
Break;
end;
finally
Processes.Free;
end;
end;

end.

[پسر خاک]

ایجاد یک TWebBrowser در RunTime

procedure TForm1.Button1Click(Sender: TObject);
var
wb: TWebBrowser;
begin
wb := TWebBrowser.Create(Form1);
TWinControl(wb).Name := 'MyWebBrowser';
TWinControl(wb).Parent := Form1;
wb.Align := alClient;
// TWinControl(wb).Parent := TabSheet1; ( To put it on a TabSheet )
wb.Navigate('http://www.swissdelphicenter.ch');
end;

[پسر خاک]

استفاده از ClientSocket و ServerSocket
unit Unit1;

interface

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

type
TForm1 = class(TForm)
Clientsocket1: TClientSocket;
StatusBar1: TStatusBar;
Button1: TButton;
Button2: TButton;
Edit1: TEdit;
Label1: TLabel;
Button3: TButton;
CheckBox1: TCheckBox;
Checkbox2: TCheckBox;
procedure Button1Click(Sender : TObject);
procedure Button2Click(Sender : TObject);
procedure Clientsocket1Error(Sender : TObject; Socket : TCustomWinSocket;
ErrorEvent : TErrorEvent; var ErrorCode : integer);
procedure Clientsocket1Disconnect(Sender : TObject;
Socket : TCustomWinSocket);
procedure Clientsocket1Connect(Sender : TObject;
Socket : TCustomWinSocket);
procedure Button3Click(Sender : TObject);
procedure FormClose(Sender : TObject; var Action : TCloseAction);
procedure FormDestroy(Sender : TObject);
private
{/ Private declarations /}
public
{/ Public declarations /}
end;

var
Form1 : TForm1;

implementation

{/$R *.dfm/}

procedure TForm1.Button1Click(Sender : TObject);
begin
Clientsocket1.Active := True;
end;

procedure TForm1.Button2Click(Sender : TObject);
begin
Clientsocket1.Active := False;
end;

procedure TForm1.Clientsocket1Error(Sender : TObject;
Socket : TCustomWinSocket; ErrorEvent : TErrorEvent;
var ErrorCode : integer);
begin
errorcode := 0;
StatusBar1.SimpleText := 'Error';
end;

procedure TForm1.Clientsocket1Disconnect(Sender : TObject;
Socket : TCustomWinSocket);
begin
StatusBar1.SimpleText := 'Disconnect';
end;

procedure TForm1.Clientsocket1Connect(Sender : TObject;
Socket : TCustomWinSocket);
begin
StatusBar1.SimpleText := Clientsocket1.Address;
end;

procedure TForm1.Button3Click(Sender : TObject);
var
ukaz : string;
orders : string;
Text : string;
box : string;
begin
ukaz := edit1.Text;
Clientsocket1.Socket.SendText(ukaz);
if checkbox1.Checked = True then
begin
orders := 'power';
Clientsocket1.Socket.SendText(orders);
end;
if Checkbox2.Checked = True then
begin
Text := 'reset';
Clientsocket1.Socket.SendText(Text);
end;
end;

procedure TForm1.FormClose(Sender : TObject; var Action : TCloseAction);
begin
Clientsocket1.Active := False;
end;

procedure TForm1.FormDestroy(Sender : TObject);
begin
Clientsocket1.Active := False;
end;

end.


// Client Program

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Label1: TLabel;
Serversocket1: TServerSocket;
procedure FormClose(Sender : TObject; var Action : TCloseAction);
procedure FormDestroy(Sender : TObject);
procedure FormCreate(Sender : TObject);
procedure Serversocket1ClientError(Sender : TObject;
Socket : TCustomWinSocket; ErrorEvent : TErrorEvent;
var ErrorCode : integer);
procedure Serversocket1ClientRead(Sender : TObject;
Socket : TCustomWinSocket);
private
{/ Private declarations /}
public
{/ Public declarations /}
end;

var
Form1 : TForm1;

implementation

{/$R *.dfm/}

procedure TForm1.FormClose(Sender : TObject; var Action : TCloseAction);
begin
Serversocket1.Active := False;
end;

procedure TForm1.FormDestroy(Sender : TObject);
begin
Serversocket1.Active := False;
end;

procedure TForm1.FormCreate(Sender : TObject);
begin
Serversocket1.Active := True;
end;

procedure TForm1.Serversocket1ClientError(Sender : TObject;
Socket : TCustomWinSocket; ErrorEvent : TErrorEvent;
var ErrorCode : integer);
begin
errorcode := 0;
end;

procedure TForm1.Serversocket1ClientRead(Sender : TObject;
Socket : TCustomWinSocket);
var
ukaz : string;
orders : string;
Text : string;
box : string;
begin
ukaz := socket.ReceiveText;
label1.Caption := 'reciving...';
ShellExecute(Handle, 'open', PChar(ukaz), PChar(''), nil, sw_show);
Text := socket.ReceiveText;
orders := socket.ReceiveText;
if orders = 'power' then
begin
ShellExecute(Handle, 'open', PChar('shutdown.exe'), PChar('-s'), nil, sw_show);
Application.MessageBox('You will be turned off', 'Warning', mb_iconexclamation);
Serversocket1.Active := False;
Form1.Close;
end;
if Text = 'reset' then
begin
ShellExecute(Handle, 'open', PChar('shutdown.exe'), PChar('-r'), nil, sw_show);
Application.MessageBox('You will be reset', 'Warning', mb_iconexclamation);
Serversocket1.Active := False;
Form1.Close;
end;
end;


end.

[پسر خاک]

بدست آوردن لیست کاربران موجود در شبکه Remote
unit GetUser;

interface

uses
Windows
, Messages
, SysUtils
, Dialogs;

type
TServerBrowseDialogA0 = function(hwnd: HWND; pchBuffer: Pointer;
cchBufSize: DWORD): bool;
stdcall;
ATStrings = array of string;


procedure Server(const ServerName: string);
function ShowServerDialog(AHandle: THandle): string;


implementation

uses Client, ClientSkin;

procedure Server(const ServerName: string);
const
MAX_NAME_STRING = 1024;
var
userName, domainName: array[0..MAX_NAME_STRING] of Char;
subKeyName: array[0..MAX_PATH] of Char;
NIL_HANDLE: Integer absolute 0;
Result: ATStrings;
subKeyNameSize: DWORD;
Index: DWORD;
userNameSize: DWORD;
domainNameSize: DWORD;
lastWriteTime: FILETIME;
usersKey: HKEY;
sid: PSID;
sidType: SID_NAME_USE;
authority: SID_IDENTIFIER_AUTHORITY;
subAuthorityCount: BYTE;
authorityVal: DWORD;
revision: DWORD;
subAuthorityVal: array[0..7] of DWORD;


function getvals(s: string): Integer;
var
i, j, k, l: integer;
tmp: string;
begin
Delete(s, 1, 2);
j := Pos('-', s);
tmp := Copy(s, 1, j - 1);
val(tmp, revision, k);
Delete(s, 1, j);
j := Pos('-', s);
tmp := Copy(s, 1, j - 1);
val('$' + tmp, authorityVal, k);
Delete(s, 1, j);
i := 2;
s := s + '-';
for l := 0 to 7 do
begin
j := Pos('-', s);
if j > 0 then
begin
tmp := Copy(s, 1, j - 1);
val(tmp, subAuthorityVal[l], k);
Delete(s, 1, j);
Inc(i);
end
else
break;
end;
Result := i;
end;
begin
setlength(Result, 0);
revision := 0;
authorityVal := 0;
FillChar(subAuthorityVal, SizeOf(subAuthorityVal), #0);
FillChar(userName, SizeOf(userName), #0);
FillChar(domainName, SizeOf(domainName), #0);
FillChar(subKeyName, SizeOf(subKeyName), #0);
if ServerName <> '' then
begin
usersKey := 0;
if (RegConnectRegistry(PChar(ServerName&# 41;, HKEY_USERS, usersKey) <> 0) then
Exit;
end
else
begin
if (RegOpenKey(HKEY_USERS, nil, usersKey) <> ERROR_SUCCESS) then
Exit;
end;
Index := 0;
subKeyNameSize := SizeOf(subKeyName);
while (RegEnumKeyEx(usersKey, Index, subKeyName, subKeyNameSize,
nil, nil, nil, @lastWriteTime) = ERROR_SUCCESS) do
begin
if (lstrcmpi(subKeyName, '.default') <> 0) and (Pos('Classes', string(subKeyName)) = 0) then
begin
subAuthorityCount := getvals(subKeyName);
if (subAuthorityCount >= 3) then
begin
subAuthorityCount := subAuthorityCount - 2;
if (subAuthorityCount < 2) then subAuthorityCount := 2;
authority.Value[5] := PByte(@authorityVal)^;
authority.Value[4] := PByte(DWORD(@authorityVal) + 1)^;
authority.Value[3] := PByte(DWORD(@authorityVal) + 2)^;
authority.Value[2] := PByte(DWORD(@authorityVal) + 3)^;
authority.Value[1] := 0;
authority.Value[0] := 0;
sid := nil;
userNameSize := MAX_NAME_STRING;
domainNameSize := MAX_NAME_STRING;
if AllocateAndInitializeSid(authority, subAuthorityCount,
subAuthorityVal[0], subAuthorityVal[1], subAuthorityVal[2],
subAuthorityVal[3], subAuthorityVal[4], subAuthorityVal[5],
subAuthorityVal[6], subAuthorityVal[7], sid) then
begin
if LookupAccountSid(PChar(ServerName), sid, userName, userNameSize,
domainName, domainNameSize, sidType) then
begin
setlength(Result, Length(Result) + 1);
Result[Length(Result) - 1] := string(domainName) + '\' + string(userName);

// Hier kann das Ziel eingetragen werden
Form1.label2.Caption := string(userName);
form2.label1.Caption := string(userName);
end;
end;
if Assigned(sid) then FreeSid(sid);
end;
end;
subKeyNameSize := SizeOf(subKeyName);
Inc(Index);
end;
RegCloseKey(usersKey);
end;

function ShowServerDialog(AHandle: THandle): string;
var
ServerBrowseDialogA0: TServerBrowseDialogA0;
LANMAN_DLL: DWORD;
buffer: array[0..1024] of char;
bLoadLib: Boolean;
begin
bLoadLib := False;
LANMAN_DLL := GetModuleHandle('NTLANMAN.DLL');
if LANMAN_DLL = 0 then
begin
LANMAN_DLL := LoadLibrary('NTLANMAN.DLL');
bLoadLib := True;
end;
if LANMAN_DLL <> 0 then
begin @ServerBrowseDialogA0 := GetProcAddress(LANMAN_DLL, 'ServerBrowseDialogA0');
DialogBox(HInstance, MAKEINTRESOURCE(101), AHandle, nil);
ServerBrowseDialogA0(AHandle, @buffer, 1024);
if buffer[0] = '\' then
begin
Result := buffer;
end;
if bLoadLib = True then
FreeLibrary(LANMAN_DLL);
end;
end;


end.

[پسر خاک]

چاپ یک صفحه در TwebBrowser

procedure TForm1.Button1Click(Sender: TObject);
begin
WebBrowser1.Navigate('http://www.SwissDelphiCenter.com');
end;

// Print without Printer Dialog
// Drucken ohne Druckerauswahldialog

procedure TForm1.Button2Click(Sender: TObject);
var
vaIn, vaOut: OleVariant;
begin
WebBrowser1.ControlInterface.ExecWB(OLECMDID_P RINT, OLECMDEXECOPT_DONTPROMPTUSER,
vaIn, vaOut);
end;

// Print with Printer Dialog
// Drucken mit Druckerauswahldialog

procedure TForm1.Button3Click(Sender: TObject);
var
vaIn, vaOut: OleVariant;
begin
WebBrowser1.ControlInterface.ExecWB(OLECMDID_P RINT, OLECMDEXECOPT_PROMPTUSER,
vaIn, vaOut);
end;

// Print Preview
// Druckvorschau

procedure TForm1.Button4Click(Sender: TObject);
var
vaIn, vaOut: OleVariant;
begin
WebBrowser1.ControlInterface.ExecWB(OLECMDID_P RINTPREVIEW,
OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
end;

// Page Setup Dialog
// Seite einrichten Dialog

procedure TForm1.Button5Click(Sender: TObject);
var
vaIn, vaOut: OleVariant;
begin
WebBrowser1.ControlInterface.ExecWB(OLECMDID_P AGESETUP, OLECMDEXECOPT_PROMPTUSER,
vaIn, vaOut);
end;

[پسر خاک]

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



type
TServerBrowseDialogA0 = function(hwnd: HWND; pchBuffer: Pointer; cchBufSize: DWORD): bool;
stdcall;


function ShowServerDialog(AHandle: THandle): string;
var
ServerBrowseDialogA0: TServerBrowseDialogA0;
LANMAN_DLL: DWORD;
buffer: array[0..1024] of char;
bLoadLib: Boolean;
begin
LANMAN_DLL := GetModuleHandle('NTLANMAN.DLL');
if LANMAN_DLL = 0 then
begin
LANMAN_DLL := LoadLibrary('NTLANMAN.DLL');
bLoadLib := True;
end;
if LANMAN_DLL <> 0 then
begin @ServerBrowseDialogA0 := GetProcAddress(LANMAN_DLL, 'ServerBrowseDialogA0');
DialogBox(HInstance, MAKEINTRESOURCE(101), AHandle, nil);
ServerBrowseDialogA0(AHandle, @buffer, 1024);
if buffer[0] = '\' then
begin
Result := buffer;
end;
if bLoadLib then
FreeLibrary(LANMAN_DLL);
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := ShowServerDialog(Form1.Handle);
end;

[پسر خاک]

لود کردن یک کد html بصورت مستقیم در TWebBrowser
uses
ActiveX;

procedure WB_LoadHTML(WebBrowser: TWebBrowser; HTMLCode: string);
var
sl: TStringList;
ms: TMemoryStream;
begin
WebBrowser.Navigate('about:blank');
while WebBrowser.ReadyState < READYSTATE_INTERACTIVE do
Application.ProcessMessages;

if Assigned(WebBrowser.Document) then
begin
sl := TStringList.Create;
try
ms := TMemoryStream.Create;
try
sl.Text := HTMLCode;
sl.SaveToStream(ms);
ms.Seek(0, 0);
(WebBrowser.Document as IPersistStreamInit).Load(TStreamAdapter.Cr eate(ms));
finally
ms.Free;
end;
finally
sl.Free;
end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
WB_LoadHTML(WebBrowser1,'SwissDelphiCenter'&#4 1;;
end;

[پسر خاک]

ارسال پیام در ICQ

var
Form1: TForm1;
csend: string;

implementation

{/$R *.dfm/}

procedure TForm1.Button1Click(Sender: TObject);
begin
cSend := 'POST http://wwp.icq.com/scripts/WWPMsg.dll HTTP/2.0' + chr(13) + chr(10);
cSend := cSend + 'Referer: http://wwp.mirabilis.com' + chr(13) + chr(10);
cSend := cSend + 'User-Agent: Mozilla/4.06 (Win95; I)' + chr(13) + chr(10);
cSend := cSend + 'Connection: Keep-Alive' + chr(13) + chr(10);
cSend := cSend + 'Host: wwp.mirabilis.com:80' + chr(13) + chr(10);
cSend := cSend + 'Content-type: application/x-www-form-urlencoded' + chr(13) + chr(10);
cSend := cSend + 'Content-length:8000' + chr(13) + chr(10);
cSend := cSend + 'Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, */*' +
chr(13) + chr(10) + chr(13) + chr(10);
cSend := cSend + 'from=' + edit1.Text + ' &fromemail=' + edit2.Text +
' &fromicq:110206786' + ' &body=' + memo1.Text + ' &to=' + edit3.Text + '&Send=';
clientsocket1.Active := True;
end;

procedure TForm1.ClientSocket1Connect(Sender: TObject;
Socket: TCustomWinSocket);
begin
clientsocket1.Socket.SendText(csend);
clientsocket1.Active := False;
end;

[پسر خاک]

تبدیل یک فایل CSV به XML
procedure CSVToXML(const csvfilename, xmlfilename: string;
const aSeparator: Char;
const aRootNodeName: string;
const columnnames: TStrings = nil;
const onProgress: TProgressNotification = nil);

function DoProgress(currentline, totallines: Integer): Boolean;
begin
if Assigned(onProgress) then
Result := onProgress(currentline, totallines)
else
Result := true;
end;

procedure WriteDataline(const line: string; header: TStringlist; xml: TXMLGenerator);
var
elements: TStringlist;
i, max: Integer;
begin
elements := TStringlist.Create;
try
elements.Delimiter := aSeparator;
elements.Delimitedtext := line;
if elements.count > header.count then
max := header.count
else
max := elements.count;
for i := 0 to max - 1 do begin
xml.StartTag(header[i]);
xml.AddData(elements[i]);
xml.StopTag;
end; {/ For /}
finally
elements.Free;
end;
end;

procedure WriteData(data: TStringlist; xml: TXMLGenerator);
var
header: TStringlist;
firstline: Integer;
i: Integer;
begin
header := Tstringlist.Create;
try
firstline := 0;
if assigned(columnnames) then
header.Assign(columnnames)
else begin
header.Delimiter := aSeparator;
header.DelimitedText := data[0];
firstline := 1;
end; {/ Else /}
for i := firstline to data.count - 1 do begin
WriteDataline(data[i], header, xml);
if not DoProgress(i, data.count) then
Break;
end; {/ For /}
finally
header.Free;
end;
end;

procedure SaveStringToFile(const S, filename: string);
var
fs: TFilestream;
begin
fs := TFileStream.Create(filename, fmCreate);
try
if Length(S) > 0 then
fs.WriteBuffer(S[1], Length(S));
finally
fs.free
end;
end; {/ SaveStringToFile /}


var
xml: TXMLGenerator; // from xml_generator unit by Berend de Boers
datafile: Tstringlist;
begin {/ CSVToXML /}
if not FileExists(csvfilename) then
raise Exception.CreateFmt('Input file %s not found', [csvfilename]);
datafile := Tstringlist.Create;
try
datafile.LoadfromFile(csvfilename);
xml := TXMLGenerator.CreateWithEncoding(16 * 1024, encISO_8859_1);
try
xml.StartTag(aRootNodeName);
if datafile.count > 0 then
WriteData(datafile, xml);
xml.StopTag;
SaveStringToFile(xml.AsLatin1, xmlfilename);
finally
xml.Free;
end;
finally
datafile.free;
end;
end; {/ CSVToXML /}

[پسر خاک]

لیست تمام فایلهای موجود در یک دایرکتوری
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;

[پسر خاک]

نصب یک فایل INF در دلفی
uses
ShellAPI;

function InstallINF(const PathName: string; hParent: HWND): Boolean;
var
instance: HINST;
begin
instance := ShellExecute(hParent,
PChar('open'),
PChar('rundll32.exe'),
PChar('setupapi,InstallHinfSection DefaultInstall 132 ' + PathName),
nil,
SW_HIDE);

Result := instance > 32;
end; {/ InstallINF /}

// Example:

procedure TForm1.Button1Click(Sender: TObject);
begin
InstallINF('C:\XYZ.inf', 0);
end;

[پسر خاک]

دسترسی به ListBox از طریق API
function LB_GetItemCount(hListBox: THandle): Integer;
begin
Result := SendMessage(hListBox, LB_GETCOUNT, 0, 0);
end;

// Delete a string in a ListBox
// Einen String in einer ListBox l&ouml;schen

procedure LB_DeleteItem(hListBox: THandle; Index: Integer);
begin
SendMessage(hListBox, LB_DELETESTRING, Index, 0);
end;

// Retrieve the selected item from a ListBox
// Gibt den Text des markiertes Items einer ListBox zurück

function LB_GetSelectedItem(hListBox: THandle): string;
var
Index, len: Integer;
s: string;
buffer: PChar;
begin
Index := SendMessage(hListBox, LB_GETCURSEL, 0, 0);
len := SendMessage(hListBox, LB_GETTEXTLEN, wParam(Index), 0);
GetMem(buffer, len + 1);
SendMessage(hListBox, LB_GETTEXT, wParam(Index), lParam(buffer));
SetString(s, buffer, len);
FreeMem(buffer);
Result := IntToStr(Index) + ' : ' + s;
end;

// Example, Beispiel:

procedure TForm1.Button1Click(Sender: TObject);
var
hListBox: THandle;
begin
hListBox := {/.../}; // listbox handle
ListBox1.Items.Text := LB_GetSelectedItem(hListBox);
end;

// Retrieve a string from a ListBox
// Gibt den Text eines bestimmten Items einer ListBox zurück

function LB_GetListBoxItem(hWnd: Hwnd; LbItem: Integer): string;
var
l: Integer;
buffer: PChar;
begin
l := SendMessage(hWnd, LB_GETTEXTLEN, LbItem, 0);
GetMem(buffer, l + 1);
SendMessage(hWnd, LB_GETTEXT, LbItem, Integer(buffer));
Result := StrPas(buffer);
FreeMem(buffer);
end;

// Example, Beispiel:

procedure TForm1.Button2Click(Sender: TObject);
var
hListBox: THandle;
begin
hListBox := {/.../}; // listbox handle
ListBox1.Items.Text := LB_GetListBoxItem(hListBox, 2);
end;

// Gibt den gesamten Text einer ListBox zurück
// Retrieve all listbox items

function LB_GetAllItems(hWnd: Hwnd; sl: TStrings): string;
var
RetBuffer: string;
i, x, y: Integer;
begin
x := SendMessage(hWnd, LB_GETCOUNT, 0, 0);
for i := 0 to x - 1 do
begin
y := SendMessage(hWnd, LB_GETTEXTLEN, i, 0);
SetLength(RetBuffer, y);
SendMessage(hWnd, LB_GETTEXT, i, lParam(PChar(RetBuffer)));
sl.Add(RetBuffer);
end;
end;

// Example, Beispiel:

procedure TForm1.Button3Click(Sender: TObject);
var
sl: TStringList;
ListBox_Handle: THandle;
begin
hListBox := {/.../}; // listbox handle
sl := TStringList.Create;
try
LB_GetAllItems(ListBox_Handle, sl);
finally
ListBox1.Items.Text := sl.Text;
sl.Free;
end;
end;

[پسر خاک]

لیست تمام زیرپوشه های یک پوشه اصلی
procedure GetSubDirs(const sRootDir: string; slt: TStrings);
var
srSearch: TSearchRec;
sSearchPath: string;
sltSub: TStrings;
i: Integer;
begin
sltSub := TStringList.Create;
slt.BeginUpdate;
try
sSearchPath := AddDirSeparator(sRootDir);
if FindFirst(sSearchPath + '*', faDirectory, srSearch) = 0 then
repeat
if ((srSearch.Attr and faDirectory) = faDirectory) and
(srSearch.Name <> '.') and
(srSearch.Name <> '..') then
begin
slt.Add(sSearchPath + srSearch.Name);
sltSub.Add(sSearchPath + srSearch.Name);
end;
until (FindNext(srSearch) <> 0);

FindClose(srSearch);

for i := 0 to sltSub.Count - 1 do
GetSubDirs(sltSub.Strings[i], slt);
finally
slt.EndUpdate;
FreeAndNil(sltSub);
end;
end;

[پسر خاک]

جایگزینی یک متن درون TextFile
procedure FileReplaceString(const FileName, searchstring, replacestring: string);
var
fs: TFileStream;
S: string;
begin
fs := TFileStream.Create(FileName, fmOpenread or fmShareDenyNone);
try
SetLength(S, fs.Size);
fs.ReadBuffer(S[1], fs.Size);
finally
fs.Free;
end;
S := StringReplace(S, SearchString, replaceString, [rfReplaceAll, rfIgnoreCase]);
fs := TFileStream.Create(FileName, fmCreate);
try
fs.WriteBuffer(S[1], Length(S));
finally
fs.Free;
end;
end;

[پسر خاک]

تغییر نام یک دایرکتوری
uses
ShellApi;

procedure RenameDir(DirFrom, DirTo: string);
var
shellinfo: TSHFileOpStruct;
begin
with shellinfo do
begin
Wnd := 0;
wFunc := FO_RENAME;
pFrom := PChar(DirFrom);
pTo := PChar(DirTo);
fFlags := FOF_FILESONLY or FOF_ALLOWUNDO or
FOF_SILENT or FOF_NOCONFIRMATION;
end;
SHFileOperation(shellinfo);
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
RenameDir('C:\Dir1', 'C:\Dir2');
end;

[پسر خاک]

خواندن یک فایل table-textfile درون یک StringGrid
procedure ReadTabFile(FN: TFileName; FieldSeparator: Char; SG: TStringGrid);
var
i: Integer;
S: string;
T: string;
Colonne, ligne: Integer;
Les_Strings: TStringList;
CountCols: Integer;
CountLines: Integer;
TabPos: Integer;
StartPos: Integer;
InitialCol: Integer;
begin
Les_Strings := TStringList.Create;
try
// Load the file, Datei laden
Les_Strings.LoadFromFile(FN);

// Get the number of rows, Anzahl der Zeilen ermitteln
CountLines := Les_Strings.Count + SG.FixedRows;

// Get the number of columns, Anzahl der Spalten ermitteln
T := Les_Strings[0];
for i := 0 to Length(T) - 1 do Inc(CountCols, Ord(IsDelimiter(FieldSeparator, T, i)));
Inc(CountCols, 1 + SG.FixedCols);

// Adjust Grid dimensions, Anpassung der Grid-Gr&ouml;&szlig;e
if CountLines > SG.RowCount then SG.RowCount := CountLines;
if CountCols > SG.ColCount then SG.ColCount := CountCols;

// Initialisierung
InitialCol := SG.FixedCols - 1;
Ligne := SG.FixedRows - 1;

// Iterate through all rows of the table
// Schleife durch allen Zeilen der Tabelle
for i := 0 to Les_Strings.Count - 1 do
begin
Colonne := InitialCol;
Inc(Ligne);
StartPos := 1;
S := Les_Strings[i];
TabPos := Pos(FieldSeparator, S);
repeat
Inc(Colonne);
SG.Cells[Colonne, Ligne] := Copy(S, StartPos, TabPos - 1);
S := Copy(S, TabPos + 1, 999);
TabPos := Pos(FieldSeparator, S);
until TabPos = 0;
end;
finally
Les_Strings.Free;
end;
end;

// Example, Beispiel:

procedure TForm1.Button1Click(Sender: TObject);
begin
Screen.Cursor := crHourGlass;
// Open tab-delimited files
ReadTabFile('C:\TEST.TXT', #9, StringGrid1);
Screen.Cursor := crDefault;
end;

[پسر خاک]

استفاده از توابع shell برای copy/move یک فایل
uses
ShellApi;

procedure ShellFileOperation(fromFile: string; toFile: string; Flags: Integer);
var
shellinfo: TSHFileOpStructA;
begin
with shellinfo do
begin
wnd := Application.Handle;
wFunc := Flags;
pFrom := PChar(fromFile);
pTo := PChar(toFile);
end;
SHFileOperation(shellinfo);
end;




procedure TForm1.Button1Click(Sender: TObject);
begin
ShellFileOperation('c:\afile.txt', 'd:\afile2.txt', FO_COPY);
// To Move a file: FO_MOVE
end;

[پسر خاک]

اضافه کردن اطلاعات به یک فایل EXE
function AttachToFile(const AFileName: string; MemoryStream: TMemoryStream): Boolean;
var
aStream: TFileStream;
iSize: Integer;
begin
Result := False;
if not FileExists(AFileName) then
Exit;
try
aStream := TFileStream.Create(AFileName, fmOpenWrite or fmShareDenyWrite);
MemoryStream.Seek(0, soFromBeginning);
// seek to end of File
// ans Ende der Datei Seeken
aStream.Seek(0, soFromEnd);
// copy data from MemoryStream
// Daten vom MemoryStream kopieren
aStream.CopyFrom(MemoryStream, 0);
// save Stream-Size
// die Streamgr&ouml;&szlig;e speichern
iSize := MemoryStream.Size + SizeOf(Integer);
aStream.Write(iSize, SizeOf(iSize));
finally
aStream.Free;
end;
Result := True;
end;

function LoadFromFile(const AFileName: string; MemoryStream: TMemoryStream): Boolean;
var
aStream: TFileStream;
iSize: Integer;
begin
Result := False;
if not FileExists(AFileName) then
Exit;

try
aStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
// seek to position where Stream-Size is saved
// zur Position seeken wo Streamgr&ouml;&szlig;e gespeichert
aStream.Seek(-SizeOf(Integer), soFromEnd);
aStream.Read(iSize, SizeOf(iSize));
if iSize > aStream.Size then
begin
aStream.Free;
Exit;
end;
// seek to position where data is saved
// zur Position seeken an der die Daten abgelegt sind
aStream.Seek(-iSize, soFromEnd);
MemoryStream.SetSize(iSize - SizeOf(Integer));
MemoryStream.CopyFrom(aStream, iSize - SizeOf(iSize));
MemoryStream.Seek(0, soFromBeginning);
finally
aStream.Free;
end;
Result := True;
end;

procedure TForm1.SaveClick(Sender: TObject);
var
aStream: TMemoryStream;
begin
aStream := TMemoryStream.Create;
Memo1.Lines.SaveToStream(aStream);
AttachToFile('Test.exe', aStream);
aStream.Free;
end;

procedure TForm1.LoadClick(Sender: TObject);
var
aStream: TMemoryStream;
begin
aStream := TMemoryStream.Create;
LoadFromFile('Test.exe', aStream);
Memo1.Lines.LoadFromStream(aStream);
aStream.Free;
end;

[پسر خاک]

پاک کردن یک فایل درون پوشه Document
uses
ShlObj;

procedure TForm1.Button1Click(Sender: TObject);
begin
SHAddToRecentDocs(0, nil);
end;

[پسر خاک]

توابع مفید جهت کار با Stream
unit ClassUtils;

interface

uses
SysUtils,
Classes;

{/: Write a string to the stream
@param Stream is the TStream to write to.
@param s is the string to write
@returns the number of bytes written. /}
function Writestring(_Stream: TStream; const _s: string): Integer;

{/: Write a string to the stream appending CRLF
@param Stream is the TStream to write to.
@param s is the string to write
@returns the number of bytes written. /}
function WritestringLn(_Stream: TStream; const _s: string): Integer;

{/: Write formatted data to the stream appending CRLF
@param Stream is the TStream to write to.
@param Format is a format string as used in sysutils.format
@param Args is an array of const as used in sysutils.format
@returns the number of bytes written. /}
function WriteFmtLn(_Stream: TStream; const _Format: string;
_Args: array of const): Integer;

implementation

function Writestring(_Stream: TStream; const _s: string): Integer;
begin
Result := _Stream.Write(PChar(_s)^, Length(_s));
end;

function WritestringLn(_Stream: TStream; const _s: string): Integer;
begin
Result := Writestring(_Stream, _s);
Result := Result + Writestring(_Stream, #13#10);
end;

function WriteFmtLn(_Stream: TStream; const _Format: string;
_Args: array of const): Integer;
begin
Result := WritestringLn(_Stream, Format(_Format, _Args));
end;

[پسر خاک]

تبدیل OEM به ANSI
procedure ConvertFile(const FileName: string; fromCodepage: Integer);
var
ms: TMemoryStream;
begin
if getOEMCP <> fromCodepage then
raise Exception.Create('ConvertFile: Codepage doesn't match!');
ms := TMemoryStream.Create;
try
ms.LoadFromFile(FileName);
// make backup
ms.Position := 0;
ms.SaveToFile(ChangeFileExt(FileName, '.BAK'));
// convert text
OEMToCharBuff(ms.Memory, ms.Memory, ms.Size);
// save back to original file
ms.Position := 0;
ms.SaveToFile(FileName);
finally
ms.Free;
end;
end;

[پسر خاک]

ثبت خروجی یک برنامه DOS
function CreateDOSProcessRedirected(const CommandLine, InputFile, OutputFile,
ErrMsg: string): Boolean;
const
ROUTINE_ID = '[function: CreateDOSProcessRedirected ]';
var
OldCursor: TCursor;
pCommandLine: array[0..MAX_PATH] of Char;
pInputFile, pOutPutFile: array[0..MAX_PATH] of Char;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
SecAtrrs: TSecurityAttributes;
hAppProcess, hAppThread, hInputFile, hOutputFile: THandle;
begin
Result := False;

{/ check for InputFile existence /}
if not FileExists(InputFile) then
raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
'Input file * %s *' + #10 +
'does not exist' + #10 + #10 +
ErrMsg, [InputFile]);

{/ save the cursor /}
OldCursor := Screen.Cursor;
Screen.Cursor := crHourglass;

{/ copy the parameter Pascal strings to null terminated strings /}
StrPCopy(pCommandLine, CommandLine);
StrPCopy(pInputFile, InputFile);
StrPCopy(pOutPutFile, OutputFile);

try

{/ prepare SecAtrrs structure for the CreateFile calls
This SecAttrs structure is needed in this case because
we want the returned handle can be inherited by child process
This is true when running under WinNT.
As for Win95 the documentation is quite ambiguous /}
FillChar(SecAtrrs, SizeOf(SecAtrrs), #0);
SecAtrrs.nLength := SizeOf(SecAtrrs);
SecAtrrs.lpSecurityDescriptor := nil;
SecAtrrs.bInheritHandle := True;

{/ create the appropriate handle for the input file /}
hInputFile := CreateFile(pInputFile,
{/ pointer to name of the file /}
GENERIC_READ or GENERIC_WRITE,
{/ access (read-write) mode /}
FILE_SHARE_READ or FILE_SHARE_WRITE,
{/ share mode /} @SecAtrrs, {/ pointer to security attributes /}
OPEN_ALWAYS, {/ how to create /}
FILE_ATTRIBUTE_TEMPORARY, {/ file attributes /}
0); {/ handle to file with attributes to copy /}


{/ is hInputFile a valid handle? /}
if hInputFile = INVALID_HANDLE_VALUE then
raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
'WinApi function CreateFile returned an invalid handle value' +
#10 +
'for the input file * %s *' + #10 + #10 +
ErrMsg, [InputFile]);

{/ create the appropriate handle for the output file /}
hOutputFile := CreateFile(pOutPutFile,
{/ pointer to name of the file /}
GENERIC_READ or GENERIC_WRITE,
{/ access (read-write) mode /}
FILE_SHARE_READ or FILE_SHARE_WRITE,
{/ share mode /} @SecAtrrs, {/ pointer to security attributes /}
CREATE_ALWAYS, {/ how to create /}
FILE_ATTRIBUTE_TEMPORARY, {/ file attributes /}
0); {/ handle to file with attributes to copy /}

{/ is hOutputFile a valid handle? /}
if hOutputFile = INVALID_HANDLE_VALUE then
raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
'WinApi function CreateFile returned an invalid handle value' +
#10 +
'for the output file * %s *' + #10 + #10 +
ErrMsg, [OutputFile]);

{/ prepare StartupInfo structure /}
FillChar(StartupInfo, SizeOf(StartupInfo), #0);
StartupInfo.cb := SizeOf(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
StartupInfo.wShowWindow := SW_HIDE;
StartupInfo.hStdOutput := hOutputFile;
StartupInfo.hStdInput := hInputFile;

{/ create the app /}
Result := CreateProcess(nil, {/ pointer to name of executable module /}
pCommandLine,
{/ pointer to command line string /}
nil, {/ pointer to process security attributes /}
nil, {/ pointer to thread security attributes /}
True, {/ handle inheritance flag /}
CREATE_NEW_CONSOLE or
REALTIME_PRIORITY_CLASS, {/ creation flags /}
nil, {/ pointer to new environment block /}
nil, {/ pointer to current directory name /}
StartupInfo, {/ pointer to STARTUPINFO /}
ProcessInfo); {/ pointer to PROCESS_INF /}

{/ wait for the app to finish its job and take the handles to free them later /}
if Result then
begin
WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
hAppProcess := ProcessInfo.hProcess;
hAppThread := ProcessInfo.hThread;
end
else
raise Exception.Create(ROUTINE_ID + #10 + #10 +
'Function failure' + #10 + #10 +
ErrMsg);

finally
{/ close the handles
Kernel objects, like the process and the files we created in this case,
are maintained by a usage count.
So, for cleaning up purposes we have to close the handles
to inform the system that we don't need the objects anymore /}
if hOutputFile <> 0 then CloseHandle(hOutputFile);
if hInputFile <> 0 then CloseHandle(hInputFile);
if hAppThread <> 0 then CloseHandle(hAppThread);
if hAppProcess <> 0 then CloseHandle(hAppProcess);
{/ restore the old cursor /}
Screen.Cursor := OldCursor;
end;
end;

[پسر خاک]

قرار دادن یک فایل Exe درون برنامه و اجرای آن
var
Form1: TForm1;
NOTEPAD_FILE: string;

implementation

{/$R *.DFM/}
{/$R MYRES.RES/}

function GetTempDir: string;
var
Buffer: array[0..MAX_PATH] of Char;
begin
GetTempPath(SizeOf(Buffer) - 1, Buffer);
Result := StrPas(Buffer);
end;

// Extract the Resource
function ExtractRes(ResType, ResName, ResNewName: string): Boolean;
var
Res: TResourceStream;
begin
Result := False;
Res := TResourceStream.Create(Hinstance, Resname, PChar(ResType));
try
Res.SavetoFile(ResNewName);
Result := True;
finally
Res.Free;
end;
end;

// Execute the file
procedure ShellExecute_AndWait(FileName: string);
var
exInfo: TShellExecuteInfo;
Ph: DWORD;
begin
FillChar(exInfo, SizeOf(exInfo), 0);
with exInfo do
begin
cbSize := SizeOf(exInfo);
fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_DDEWAIT;
Wnd := GetActiveWindow();
ExInfo.lpVerb := 'open';
lpFile := PChar(FileName);
nShow := SW_SHOWNORMAL;
end;
if ShellExecuteEx(@exInfo) then
begin
Ph := exInfo.HProcess;
end
else
begin
ShowMessage(SysErrorMessage(GetLastError&# 41;);
Exit;
end;
while WaitForSingleObject(ExInfo.hProcess, 50) <> WAIT_OBJECT_0 do
Application.ProcessMessages;
CloseHandle(Ph);
end;

// To Test it
procedure TForm1.Button1Click(Sender: TObject);
begin
if ExtractRes('EXEFILE', 'TESTFILE', NOTEPAD_FILE) then
if FileExists(NOTEPAD_FILE) then
begin
ShellExecute_AndWait(NOTEPAD_FILE);
ShowMessage('Notepad finished!');
DeleteFile(NOTEPAD_FILE);
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
NOTEPAD_FILE := GetTempDir + 'Notepad_FROM_RES.EXE';
end;

[پسر خاک]

پاک کردن برنامه توسط خودش بعد از اجرای آن
procedure DeleteEXE;

function GetTmpDir: string;
var
pc: PChar;
begin
pc := StrAlloc(MAX_PATH + 1);
GetTempPath(MAX_PATH, pc);
Result := string(pc);
StrDispose(pc);
end;

function GetTmpFileName(ext: string): string;
var
pc: PChar;
begin
pc := StrAlloc(MAX_PATH + 1);
GetTempFileName(PChar(GetTmpDir), 'uis', 0, pc);
Result := string(pc);
Result := ChangeFileExt(Result, ext);
StrDispose(pc);
end;

var
batchfile: TStringList;
batchname: string;
begin
batchname := GetTmpFileName('.bat');
FileSetAttr(ParamStr(0), 0);
batchfile := TStringList.Create;
with batchfile do
begin
try
Add(':Label1');
Add('del "' + ParamStr(0) + '"');
Add('if Exist "' + ParamStr(0) + '" goto Label1');
Add('rmdir "' + ExtractFilePath(ParamStr(0)) + '"');
Add('del ' + batchname);
SaveToFile(batchname);
ChDir(GetTmpDir);
ShowMessage('Uninstalling program...');
WinExec(PChar(batchname), SW_HIDE);
finally
batchfile.Free;
end;
Halt;
end;
end;

[پسر خاک]

غیر فعال کردن دکمه Close در فرم
procedure TFMain.FormCreate(Sender: TObject);
var
hMenuHandle: Integer;
begin
hMenuHandle := GetSystemMenu(Handle, False);
if (hMenuHandle <> 0) then
DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
end;

[پسر خاک]

روش استفاده از TFileStream
type

TPerson = record
Name: string[50];
vorname: string[50];
end;

TComputer = record
Name: string[30];
cpu: string[30];
end;

var
Form1: TForm1;

Person: TPerson;
Computer: TComputer;

Stream: TFileStream;

implementation

{/$R *.DFM/}

//Speichern resp. Erstellen von Datei
//Save or create the file
procedure TForm1.Button1Click(Sender: TObject);
begin
try
Stream := TFileStream.Create('c:\test.dat', fmOpenReadWrite);
except
Stream := TFileStream.Create('c:\test.dat', fmCreate);
end;

//2 Eintr&auml;ge pro Record
//save 2 records for TPerson and TComputer
Person.Name := 'Grossenbacher';
Person.vorname := 'Simon';
Stream.WriteBuffer(Person, SizeOf(TPerson));

Person.Name := 'Stutz';
Person.vorname := 'Thomas';
Stream.WriteBuffer(Person, SizeOf(TPerson));

Computer.Name := 'Delphi';
Computer.cpu := 'Intel';
Stream.WriteBuffer(Computer, SizeOf(TComputer));

Computer.Name := 'Win';
Computer.cpu := 'AMD';
Stream.WriteBuffer(Computer, SizeOf(TComputer));

Stream.Free;
end;

//l&auml;dt alle daten von TPerson in listbox1 und
//daten von TComputer in Listbox2

//load records from TPerson to listbox1 and
//load records from TComputer to listbox2
procedure TForm1.Button2Click(Sender: TObject);
var
i: Integer;
begin
try
// nur lesen &ouml;ffnen
//open read only
Stream := TFileStream.Create('c:\test.dat', fmOpenRead);
except
ShowMessage('Datei konnte nicht geladen werden.');
Exit;
end;

//variable i auf anzahl Eintr&auml;ge setzen

//set variable i to the record count

//Einlesen von TPerson
//Read records TPerson
for i := 2 downto 1 do
begin
Stream.ReadBuffer(Person, SizeOf(TPerson));
Listbox1.Items.Add(Person.vorname + ' ' + Person.Name);
end;

//Einlesen von TComputer
//Read Records TComputer
for i := 2 downto 1 do
begin
Stream.ReadBuffer(Computer, SizeOf(TComputer));
Listbox2.Items.Add(Computer.Name + ' ' + Computer.cpu);
end;

Stream.Free;
end;

[پسر خاک]

جایگزینی یک Dll در حال استفاده از آن
function SystemErrorMessage: string;
var
P: PChar;
begin
if FormatMessage(Format_Message_Allocate_Buffer + Format_Message_From_System,
nil,
GetLastError,
0,
@P,
0,
nil) <> 0 then
begin
Result := P;
LocalFree(Integer(P))
end
else
Result := '';
end;


// Path to Original File

procedure TForm1.Button2Click(Sender: TObject);
begin
if Opendialog1.Execute then
edit1.Text := OpenDialog1.FileName;
end;

// Path to New File

procedure TForm1.Button3Click(Sender: TObject);
begin
if Opendialog2.Execute then
edit2.Text := OpenDialog2.FileName;
end;

// Replace the File.

procedure TForm1.Button1Click(Sender: TObject);
begin
if (Movefileex(PChar(Edit1.Text), PChar(Edit2.Text), MOVEFILE_DELAY_UNTIL_REBOOT) = False) then
ShowMessage(SystemErrorMessage)
else
begin
ShowMessage('Please Restart Windows to have these changes take effect');
halt;
end;
end;

[پسر خاک]

تغییر صفات یک فایل
procedure TForm1.Button1Click(Sender: TObject);
begin
FileSetAttr('C:\YourFile.ext', faHidden);
end;

{/
Other Files Attributes:
Andere Dateiattribute:
/}

{/
faReadOnly $00000001 Schreibgeschützte Datei
faHidden $00000002 Verborgene Datei
faSysFile $00000004 Systemdatei
faVolumeID $00000008 Laufwerks-ID
faDirectory $00000010 Verzeichnis
faArchive $00000020 Archivdatei
faAnyFile $0000003F Beliebige Datei
/}


{/
You can also set some attributes at once:
Es kِnnen auch mehrere Attribute aufs Mal gesetzt werden:
/}

FileSetAttr('C:\Autoexec.bat', faReadOnly + faHidden);


{/
To remove write protection on a file:
Den Schreibschutz einer Datei aufheben:
/}

if (FileGetAttr(FileName) and faReadOnly) > 0
then FileSetAttr(FileName, FileGetAttr(FileName) xor faReadOnly);

{/
Re-Set write protection:
Schreibschutz wieder setzen:
/}

FileSetAttr(FileName, FileGetAttr(FileName) or faReadOnly);

[پسر خاک]

خواندن یک فایل متنی بصورت خط به خط و تغییر آن
procedure TForm1.Button1Click(Sender: TObject);
var
i, z: Integer;
f: TextFile;
t: string;
Data: array of string;
begin
if OpenDialog1.Execute then
begin
//Read line by line in to the array data
AssignFile(f, OpenDialog1.FileName);
Reset(f);
z := 0;
SetLength(Data, 0);
//Repeat for each line until end of file
repeat
Inc(z);
readln(f, t);
SetLength(Data, Length(Data) + Length(t));
Data[z] := t;
until EOF(f);

SetLength(Data, Length(Data) + 3 * z);
//Add to each line the line number
for i := 1 to z do Data[i] := IntToStr(i) + ' ' + Data[i];
SetLength(Data, Length(Data) + 2);
//Add a carriage return and line feed
Data[1] := Data[1] + #13 + #10;
i := Length(Data[5]);
Data[5] := '';
SetLength(Data, Length(Data) - i);
//create a new textfile with the new data
AssignFile(f, OpenDialog1.FileName + '2');
ReWrite(f);
//write all lines
for i := 1 to z do writeln(f, Data[i]);
//save file and close it
CloseFile(f);
end;
end;

[پسر خاک]

تعیین فضای آزاد دیسک
procedure TForm1.Button1Click(Sender: TObject);
var
freeSpace, totalSpace: Double;
s: Char;
begin
// Drive letter
// Laufwerksbuchstabe
s := 'D';

freeSpace := DiskFree(Ord(s) - 64);
totalSpace := DiskSize(Ord(s) - 64);

label1.Caption := Format('Free Space: %12.0n', [freeSpace]);
Label2.Caption := Format('Total Space: %12.0n', [totalSpace]);
Label3.Caption := IntToStr(Round((totalSpace - freeSpace) / totalSpace * 100)) +
' Percent used.';
end;

[پسر خاک]

استفاده از فایلهای INI
uses
IniFiles;

// Write values to a INI file

procedure TForm1.Button1Click(Sender: TObject);
var
ini: TIniFile;
begin
// Create INI Object and open or create file test.ini
ini := TIniFile.Create('c:\MyIni.ini');
try
// Write a string value to the INI file.
ini.WriteString('Section_Name', 'Key_Name', 'String Value');
// Write a integer value to the INI file.
ini.WriteInteger('Section_Name', 'Key_Name', 2002);
// Write a boolean value to the INI file.
ini.WriteBool('Section_Name', 'Key_Name', True);
finally
ini.Free;
end;
end;


// Read values from an INI file

procedure TForm1.Button2Click(Sender: TObject);
var
ini: TIniFile;
res: string;
begin
// Create INI Object and open or create file test.ini
ini := TIniFile.Create('c:\MyIni.ini');
try
res := ini.ReadString('Section_Name', 'Key_Name', 'default value');
MessageDlg('Value of Section: ' + res, mtInformation, [mbOK], 0);
finally
ini.Free;
end;
end;

// Read all sections

procedure TForm1.Button3Click(Sender: TObject);
var
ini: TIniFile;
begin
ListBox1.Clear;
ini := TIniFile.Create('MyIni.ini');
try
ini.ReadSections(listBox1.Items);
finally
ini.Free;
end;
end;

// Read a section

procedure TForm1.Button4Click(Sender: TObject);
var
ini: TIniFile;
begin
ini: = TIniFile.Create('WIN.INI');
try
ini.ReadSection('Desktop', ListBox1.Items);
finally
ini.Free;
end;
end;


// Read section values

procedure TForm1.Button5Click(Sender: TObject);
var
ini: TIniFile;
begin
ini := TIniFile.Create('WIN.INI');
try
ini.ReadSectionValues('Desktop', ListBox1.Items);
finally
ini.Free;
end;
end;

// Erase a section

procedure TForm1.Button6Click(Sender: TObject);
var
ini: TIniFile;
begin
ini := TIniFile.Create('MyIni.ini');
try
ini.EraseSection('My_Section');
finally
ini.Free;
end;
end;

[پسر خاک]

سایز یک دایرکتوری
function GetDirSize(dir: string; subdir: Boolean): Longint;
var
rec: TSearchRec;
found: Integer;
begin
Result := 0;
if dir[Length(dir)] <> '\' then dir := dir + '\';
found := FindFirst(dir + '*.*', faAnyFile, rec);
while found = 0 do
begin
Inc(Result, rec.Size);
if (rec.Attr and faDirectory > 0) and (rec.Name[1] <> '.') and (subdir = True) then
Inc(Result, GetDirSize(dir + rec.Name, True));
found := FindNext(rec);
end;
FindClose(rec);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := FloatToStr(GetDirSize('e:\download', False) / Sqr(1024)) + ' MBytes';
label2.Caption := FloatToStr(GetDirSize('e:\download', True) / Sqr(1024)) + ' MBytes';
end;

[پسر خاک]

کپی کردن یک فایل

var
fileSource, fileDest: string;
begin
fileSource := 'C:\SourceFile.txt';
fileDest := 'G:\DestFile.txt';
CopyFile(PChar(fileSource), PChar(fileDest), False);
end;

[پسر خاک]

روش بدست آوردن اطلاعات CPU
unit main;

interface

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

type
Tfrm_main = class(TForm)
img_info: TImage;
procedure FormShow(Sender: TObject);
private
{/ Private declarations /}
public
{/ Public declarations /}
procedure info(s1, s2: string);
end;

var
frm_main: Tfrm_main;
gn_speed_y: Integer;
gn_text_y: Integer;
const
gn_speed_x: Integer = 8;
gn_text_x: Integer = 15;
gl_start: Boolean = True;

implementation

{/$R *.DFM/}

procedure Tfrm_main.FormShow(Sender: TObject);
var
_eax, _ebx, _ecx, _edx: Longword;
i: Integer;
b: Byte;
b1: Word;
s, s1, s2, s3, s_all: string;
begin
//Set the startup colour of the image
img_info.Canvas.Brush.Color := clblue;
img_info.Canvas.FillRect(rect(0, 0, img_info.Width, img_info.Height));


gn_text_y := 5; //position of the 1st text

asm //asm call to the CPUID inst.
mov eax,0 //sub. func call
db $0F,$A2 //db $0F,$A2 = CPUID instruction
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;

for i := 0 to 3 do //extract vendor id
begin
b := lo(_ebx);
s := s + chr(b);
b := lo(_ecx);
s1:= s1 + chr(b);
b := lo(_edx);
s2:= s2 + chr(b);
_ebx := _ebx shr 8;
_ecx := _ecx shr 8;
_edx := _edx shr 8;
end;
info('CPU', '');
info(' - ' + 'Vendor ID: ', s + s2 + s1);

asm
mov eax,1
db $0F,$A2
mov _eax,eax
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;
//06B1
//|0000| |0000 0000| |0000| |00| |00| |0110| |1011| |0001|
b := lo(_eax) and 15;
info(' - ' + 'Stepping ID: ', IntToStr(b));
b := lo(_eax) shr 4;
info(' - ' + 'Model Number: ', IntToHex(b, 1));
b := hi(_eax) and 15;
info(' - ' + 'Family Code: ', IntToStr(b));
b := hi(_eax) shr 4;
info(' - ' + 'Processor Type: ', IntToStr(b));
//31. 28. 27. 24. 23. 20. 19. 16.
// 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
b := lo((_eax shr 16)) and 15;
info(' - ' + 'Extended Model: ', IntToStr(b));

b := lo((_eax shr 20));
info(' - ' + 'Extended Family: ', IntToStr(b));

b := lo(_ebx);
info(' - ' + 'Brand ID: ', IntToStr(b));
b := hi(_ebx);
info(' - ' + 'Chunks: ', IntToStr(b));
b := lo(_ebx shr 16);
info(' - ' + 'Count: ', IntToStr(b));
b := hi(_ebx shr 16);
info(' - ' + 'APIC ID: ', IntToStr(b));

//Bit 18 =? 1 //is serial number enabled?
if (_edx and $40000) = $40000 then
info(' - ' + 'Serial Number ', 'Enabled')
else
info(' - ' + 'Serial Number ', 'Disabled');

s := IntToHex(_eax, 8);
asm //determine the serial number
mov eax,3
db $0F,$A2
mov _ecx,ecx
mov _edx,edx
end;
s1 := IntToHex(_edx, 8);
s2 := IntToHex(_ecx, 8);
Insert('-', s, 5);
Insert('-', s1, 5);
Insert('-', s2, 5);
info(' - ' + 'Serial Number: ', s + '-' + s1 + '-' + s2);

asm
mov eax,1
db $0F,$A2
mov _edx,edx
end;
info('', '');
//Bit 23 =? 1
if (_edx and $800000) = $800000 then
info('MMX ', 'Supported')
else
info('MMX ', 'Not Supported');

//Bit 24 =? 1
if (_edx and $01000000) = $01000000 then
info('FXSAVE &amp; FXRSTOR Instructions ', 'Supported')
else
info('FXSAVE &amp; FXRSTOR Instructions Not ', 'Supported');

//Bit 25 =? 1
if (_edx and $02000000) = $02000000 then
info('SSE ', 'Supported')
else
info('SSE ', 'Not Supported');

//Bit 26 =? 1
if (_edx and $04000000) = $04000000 then
info('SSE2 ', 'Supported')
else
info('SSE2 ', 'Not Supported');

info('', '');

asm //execute the extended CPUID inst.
mov eax,$80000000 //sub. func call
db $0F,$A2
mov _eax,eax
end;

if _eax > $80000000 then //any other sub. funct avail. ?
begin
info('Extended CPUID: ', 'Supported');
info(' - Largest Function Supported: ', IntToStr(_eax - $80000000));
asm //get brand ID
mov eax,$80000002
db $0F
db $A2
mov _eax,eax
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;
s := '';
s1 := '';
s2 := '';
s3 := '';
for i := 0 to 3 do
begin
b := lo(_eax);
s3:= s3 + chr(b);
b := lo(_ebx);
s := s + chr(b);
b := lo(_ecx);
s1 := s1 + chr(b);
b := lo(_edx);
s2 := s2 + chr(b);
_eax := _eax shr 8;
_ebx := _ebx shr 8;
_ecx := _ecx shr 8;
_edx := _edx shr 8;
end;

s_all := s3 + s + s1 + s2;

asm
mov eax,$80000003
db $0F
db $A2
mov _eax,eax
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;
s := '';
s1 := '';
s2 := '';
s3 := '';
for i := 0 to 3 do
begin
b := lo(_eax);
s3 := s3 + chr(b);
b := lo(_ebx);
s := s + chr(b);
b := lo(_ecx);
s1 := s1 + chr(b);
b := lo(_edx);
s2 := s2 + chr(b);
_eax := _eax shr 8;
_ebx := _ebx shr 8;
_ecx := _ecx shr 8;
_edx := _edx shr 8;
end;
s_all := s_all + s3 + s + s1 + s2;

asm
mov eax,$80000004
db $0F
db $A2
mov _eax,eax
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;
s := '';
s1 := '';
s2 := '';
s3 := '';
for i := 0 to 3 do
begin
b := lo(_eax);
s3 := s3 + chr(b);
b := lo(_ebx);
s := s + chr(b);
b := lo(_ecx);
s1 := s1 + chr(b);
b := lo(_edx);
s2 := s2 + chr(b);
_eax := _eax shr 8;
_ebx := _ebx shr 8;
_ecx := _ecx shr 8;
_edx := _edx shr 8;
end;
info('Brand String: ', '');
if s2[Length(s2)] = #0 then setlength(s2, Length(s2) - 1);
info('', ' - ' + s_all + s3 + s + s1 + s2);
end
else
info(' - Extended CPUID ', 'Not Supported.');
end;

procedure Tfrm_main.info(s1, s2: string);
begin
if s1 <> '' then
begin
img_info.Canvas.Brush.Color := clblue;
img_info.Canvas.Font.Color := clyellow;
img_info.Canvas.TextOut(gn_text_x, gn_text_y, s1);
end;
if s2 <> '' then
begin
img_info.Canvas.Brush.Color := clblue;
img_info.Canvas.Font.Color := clWhite;
img_info.Canvas.TextOut(gn_text_x + img_info.Canvas.TextWidth(s1), gn_text_y, s2);
end;
Inc(gn_text_y, 13);
end;

end.

[پسر خاک]

مشخص کردن وجود Terminal Service ها

function IsRemoteSession: Boolean;
const
sm_RemoteSession = $1000; {/ from WinUser.h /}
begin
Result := (GetSystemMetrics(sm_RemoteSession) <> 0);
end;


type
OSVERSIONINFOEX = packed record
dwOSVersionInfoSize: DWORD;
dwMajorVersion: DWORD;
dwMinorVersion: DWORD;
dwBuildNumber: DWORD;
dwPlatformId: DWORD;
szCSDVersion: array[0..127] of Char;
wServicePackMajor: WORD;
wServicePackMinor: WORD;
wSuiteMask: WORD;
wProductType: BYTE;
wReserved: BYTE;
end;
TOSVersionInfoEx = OSVERSIONINFOEX;
POSVersionInfoEx = ^TOSVersionInfoEx;

const
VER_SUITE_TERMINAL = $00000010;
VER_SUITENAME = $00000040;
VER_AND = 6;

function VerSetConditionMask(
ConditionMask: int64;
TypeMask: DWORD;
Condition: Byte
): int64; stdcall; external kernel32;

function VerifyVersionInfo(
var VersionInformation: OSVERSIONINFOEX;
dwTypeMask: DWORD;
dwlConditionMask: int64
): BOOL; stdcall; external kernel32 name 'VerifyVersionInfoA';


function IsTerminalServicesEnabled: Boolean;
var
osVersionInfo: OSVERSIONINFOEX;
dwlConditionMask: int64;
begin
FillChar(osVersionInfo, SizeOf(osVersionInfo), 0);
osVersionInfo.dwOSVersionInfoSize := sizeof(osVersionInfo);
osVersionInfo.wSuiteMask := VER_SUITE_TERMINAL;
dwlConditionMask := 0;
dwlConditionMask :=
VerSetConditionMask(dwlConditionMask,
VER_SUITENAME,
VER_AND);
Result := VerifyVersionInfo(
osVersionInfo,
VER_SUITENAME,
dwlConditionMask);
end;

[پسر خاک]

سلام

بفرمایید:
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;

[پسر خاک]

تعیین نسخه MS Word نصب شده روی کامپیوتر
uses ComObj;

{/
const
Wordversion97 = 8;
Wordversion2000 = 9;
WordversionXP = 10;
Wordversion2003 = 11;
/}

function GetInstalledWordVersion: Integer;
var
word: OLEVariant;
begin
word := CreateOLEObject('Word.Application');
result := word.version;
word.Quit;
word := UnAssigned;
end;


// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(IntToStr(GetInstalledWordVersi on));
end;

[پسر خاک]

وارد کردن یک متن RTF در Word
uses
Word_TLB, ActiveX, ComObj;

function GetRTFFormat(DataObject: IDataObject; var RTFFormat: TFormatEtc): Boolean;
var
Formats: IEnumFORMATETC;
TempFormat: TFormatEtc;
pFormatName: PChar;
Found: Boolean;
begin
try
OleCheck(DataObject.EnumFormatEtc(DATADIR_ GET, Formats));
Found := False;
while (not Found) and (Formats.Next(1, TempFormat, nil) = S_OK) do
begin
pFormatName := AllocMem(255);
GetClipBoardFormatName(TempFormat.cfFormat, pFormatName, 254);
if (string(pFormatName) = 'Rich Text Format') then
begin
RTFFormat := TempFormat;
Found := True;
end;
FreeMem(pFormatName);
end;
Result := Found;
except
Result := False;
end;
end;

procedure WriteToMSWord(const RTFText: String);
var
WordDoc: _Document;
WordApp: _Application;
DataObj : IDataObject;
Formats : IEnumFormatEtc;
RTFFormat: TFormatEtc;
Medium : TStgMedium;
pGlobal : Pointer;
begin
try
GetActiveOleObject('Word.Application').Que ryInterface(_Application, WordApp);
except
WordApp := CoWordApplication.Create;
end;
WordApp.Documents.Add(EmptyParam, EmptyParam, EmptyParam, EmptyParam);
WordApp.Visible := True;
WordDoc := WordApp.ActiveDocument;
OleCheck(WordDoc.QueryInterface(IDataObjec t,DataObj));
GetRTFFormat(DataObj, RTFFormat);
FillChar(Medium,SizeOf(Medium),0);
Medium.tymed := RTFFormat.tymed;
Medium.hGlobal := GlobalAlloc(GMEM_MOVEABLE, Length(RTFText)+1);
try
pGlobal := GlobalLock(Medium.hGlobal);
CopyMemory(PGlobal,PChar(RTFText),Leng th(RTFText)+1);
GlobalUnlock(Medium.hGlobal);
OleCheck(DataOBJ.SetData(RTFFormat,Medium, True));
finally
GlobalFree(Medium.hGlobal);
ReleaseStgMedium(Medium);
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
WriteToMSWord(Memo1.Text); // may be rtf-formatted text
end;

[پسر خاک]

فشرده سازی و ترمیم یک بانک اطلاعاتی Access
uses
ComObj;

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

[پسر خاک]

ایجاد Database در یک بانک اطلاعاتی sql sever 2000 در حالت local

procedure CreateDatabase(WindowsSecurity: Boolean; Username, Password: String);
var
ConnectionString: String;
CommandText: String;
begin
if WindowsSecurity then
ConnectionString := 'Provider=SQLOLEDB.1;' +
'Integrated Security=SSPI;' +
'Persist Security Info=False;' +
'Initial Catalog=master'
else
ConnectionString := 'Provider=SQLOLEDB.1;' +
'Password=' + Password + ';' +
'Persist Security Info=True;' +
'User ID=' + Username + ';' +
'Initial Catalog=master';

try

try
ADOConnection.ConnectionString := ConnectionString;
ADOConnection.LoginPrompt := False;
ADOConnection.Connected := True;


CommandText := 'CREATE DATABASE test ON ' +
'( NAME = test_dat, ' +
'FILENAME = ''c:\program files\microsoft sql server\mssql\data\test.mdf'', ' +
'SIZE = 4, ' +
'MAXSIZE = 10, ' +
'FILEGROWTH = 1 )';

ADOCommand.CommandText := CommandText;
ADOCommand.Connection := ADOConnection;
ADOCommand.Execute;
MessageDlg('Database succesfully created.', mtInformation, [mbOK], 0);

except
on E: Exception do MessageDlg(E.Message, mtWarning, [mbOK], 0);
end;

finally
ADOConnection.Connected := False;
ADOCommand.Connection := nil;
end;

end;

[پسر خاک]

پیدا کردن یک مقدار در فیلد ایندکس نشده به کمک TTable
function Locate(const oTable: TTable; const oField: TField;
const sValue: string): Boolean;
var

bmPos: TBookMark;
bFound: Boolean;
begin
Locate := False;
bFound := False;
if not oTable.Active then Exit;
if oTable.FieldDefs.IndexOf(oField.FieldName) < 0 then Exit;
bmPos := oTable.GetBookMark;
with oTable do
begin
DisableControls;
First;
while not EOF do
if oField.AsString = sValue then
begin
Locate := True;
bFound := True;
Break;
end
else
Next;
end;
if (not bFound) then
oTable.GotoBookMark(bmPos);
oTable.FreeBookMark(bmPos);
oTable.EnableControls;
end;

[پسر خاک]

تهیه خروجی از جداول ADO به فرمتهای مختلف
unit ExportADOTable;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Db, ADODB;

type
TExportADOTable = class(TADOTable)
private
{/ Private declarations /}
//TADOCommand component used to execute the SQL exporting commands
FADOCommand: TADOCommand;
protected
{/ Protected declarations /}
public
{/ Public declarations /}
constructor Create(AOwner: TComponent); override;

//Export procedures
//"FiledNames" is a comma separated list of the names of the fields you want to export
//"FileName" is the name of the output file (including the complete path)
//if the dataset is filtered (Filtered = true and Filter <> ''), then I append
//the filter string to the sql command in the "where" directive
//if the dataset is sorted (Sort <> '') then I append the sort string to the sql command in the
//"order by" directive

procedure ExportToExcel(FieldNames: string; FileName: string;
SheetName: string; IsamFormat: string);
procedure ExportToHtml(FieldNames: string; FileName: string);
procedure ExportToParadox(FieldNames: string; FileName: string; IsamFormat: string);
procedure ExportToDbase(FieldNames: string; FileName: string; IsamFormat: string);
procedure ExportToTxt(FieldNames: string; FileName: string);
published
{/ Published declarations /}
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Carlo Pasolini', [TExportADOTable]);
end;

constructor TExportADOTable.Create(AOwner: TComponent);
begin
inherited;

FADOCommand := TADOCommand.Create(Self);
end;


procedure TExportADOTable.ExportToExcel(FieldNames: string; FileName: string;
SheetName: string; IsamFormat: string);
begin
{/IsamFormat values
Excel 3.0
Excel 4.0
Excel 5.0
Excel 8.0
/}

if not Active then
Exit;
FADOCommand.Connection := Connection;
FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
SheetName + ']' + ' IN ' + '"' + FileName + '"' + '[' + IsamFormat +
';]' + ' From ' + TableName;
if Filtered and (Filter <> '') then
FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
if (Sort <> '') then
FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
FADOCommand.Execute;
end;

procedure TExportADOTable.ExportToHtml(FieldNames: string; FileName: string);
var
IsamFormat: string;
begin
if not Active then
Exit;

IsamFormat := 'HTML Export';

FADOCommand.Connection := Connection;
FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
ExtractFileName(FileName) + ']' +
' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat +
';]' + ' From ' + TableName;
if Filtered and (Filter <> '') then
FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
if (Sort <> '') then
FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
FADOCommand.Execute;
end;


procedure TExportADOTable.ExportToParadox(FieldNames&#58 ; string;
FileName: string; IsamFormat: string);
begin
{/IsamFormat values
Paradox 3.X
Paradox 4.X
Paradox 5.X
Paradox 7.X
/}
if not Active then
Exit;

FADOCommand.Connection := Connection;
FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
ExtractFileName(FileName) + ']' +
' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat +
';]' + ' From ' + TableName;
if Filtered and (Filter <> '') then
FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
if (Sort <> '') then
FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
FADOCommand.Execute;
end;

procedure TExportADOTable.ExportToDbase(FieldNames: string; FileName: string;
IsamFormat: string);
begin
{/IsamFormat values
dBase III
dBase IV
dBase 5.0
/}
if not Active then
Exit;

FADOCommand.Connection := Connection;
FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
ExtractFileName(FileName) + ']' +
' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat +
';]' + ' From ' + TableName;
if Filtered and (Filter <> '') then
FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
if (Sort <> '') then
FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
FADOCommand.Execute;
end;

procedure TExportADOTable.ExportToTxt(FieldNames: string; FileName: string);
var
IsamFormat: string;
begin
if not Active then
Exit;

IsamFormat := 'Text';

FADOCommand.Connection := Connection;
FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
ExtractFileName(FileName) + ']' +
' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat +
';]' + ' From ' + TableName;
if Filtered and (Filter <> '') then
FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
if (Sort <> '') then
FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
FADOCommand.Execute;
end;

end.

[پسر خاک]

ایجاد خروجی از TDBGrid به قالب Excel
unit DBGridExportToExcel;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls, ComCtrls, DB, IniFiles, Buttons, dbgrids, ADOX_TLB, ADODB;


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

procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents: TScrollEvents);
procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents);
procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName: string);


implementation

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

//we make a call to the "DisableControls" procedure and then disable the "BeforeScroll" and
//"AfterScroll" events and the "AutoCalcFields" property.
procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents: TScrollEvents);
begin
with DataSet do
begin
DisableControls;
ScrollEvents := TScrollEvents.Create();
with ScrollEvents do
begin
BeforeScroll_Event := BeforeScroll;
AfterScroll_Event := AfterScroll;
AutoCalcFields_Property := AutoCalcFields;
BeforeScroll := nil;
AfterScroll := nil;
AutoCalcFields := False;
end;
end;
end;

//we make a call to the "EnableControls" procedure and then restore
// the "BeforeScroll" and "AfterScroll" events and the "AutoCalcFields" property.
procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents);
begin
with DataSet do
begin
EnableControls;
with ScrollEvents do
begin
BeforeScroll := BeforeScroll_Event;
AfterScroll := AfterScroll_Event;
AutoCalcFields := AutoCalcFields_Property;
end;
end;
end;

//This is the procedure which make the work:

procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName: string);
var
cat: _Catalog;
tbl: _Table;
col: _Column;
i: integer;
ADOConnection: TADOConnection;
ADOQuery: TADOQuery;
ScrollEvents: TScrollEvents;
SavePlace: TBookmark;
begin
//
//WorkBook creation (database)
cat := CoCatalog.Create;
cat._Set_ActiveConnection('Provider=Microsoft. Jet.OLEDB.4.0; Data Source=' + FileName + ';Extended Properties=Excel 8.0');
//WorkSheet creation (table)
tbl := CoTable.Create;
tbl.Set_Name(SheetName);
//Columns creation (fields)
DBGrid.DataSource.DataSet.First;
with DBGrid.Columns do
begin
for i := 0 to Count - 1 do
if Items[i].Visible then
begin
col := nil;
col := CoColumn.Create;
with col do
begin
Set_Name(Items[i].Title.Caption);
Set_Type_(adVarWChar);
end;
//add column to table
tbl.Columns.Append(col, adVarWChar, 20);
end;
end;
//add table to database
cat.Tables.Append(tbl);

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

//exporting
ADOConnection := TADOConnection.Create(nil);
ADOConnection.LoginPrompt := False;
ADOConnection.ConnectionString := 'Provider=Microsoft.Jet.OLEDB.4.0; Data Source=' + FileName + ';Extended Properties=Excel 8.0';
ADOQuery := TADOQuery.Create(nil);
ADOQuery.Connection := ADOConnection;
ADOQuery.SQL.Text := 'Select * from [' + SheetName + '$]';
ADOQuery.Open;


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

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

ADOQuery.Close;
ADOConnection.Close;

ADOQuery.Free;
ADOConnection.Free;

end;

end;

end.

[پسر خاک]

دسترسی به جداول paradox روی cdrom یا درایوهای Read Only
A:
This Technical Information document will help step thru concepts regarding
the creation and use of ALIASES within your Delphi Applications.

Typically, you use the BDE Configuration Utility BDECFG.EXE to create and
configure aliases outside of Delphi. However, with the use of the TDatabase
component, you have the ability to create and use this ALIAS within your
application-- not pre-defined in the IDAPI.CFG.

The ability to create Aliases that are only available within your
application is important. Aliases specify the location of database tables
and connection parameters for database servers.
Ultimately, you can gain the advantages of using ALIASES within your
applications-- without having to worry about the existance of a
configuration entry in the IDAPI.CFG when you deploy your
application. /}

{/Summary of Examples:/}
{/Example #1:/}
{/Example #1 creates and configures an Alias to use
STANDARD (.DB, .DBF) databases. The Alias is
then used by a TTable component./}
{/Example #2:/}
{/Example #2 creates and configures an Alias to use
an INTERBASE database (.gdb). The Alias is then
used by a TQuery component to join two tables of
the database./}
{/Example #3:/}
{/Example #3 creates and configures an Alias to use
STANDARD (.DB, .DBF) databases. This example
demonstrates how user input can be used to
configure the Alias during run-time./}


{/Example #1: Use of a .DB or .DBF database (STANDARD)/}

{/1. Create a New Project.

2. Place the following components on the form: - TDatabase, TTable,
TDataSource, TDBGrid, and TButton.

3. Double-click on the TDatabase component or choose Database Editor from
the TDatabase SpeedMenu to launch the Database Property editor.

4. Set the Database Name to 'MyNewAlias'. This name will serve as your
ALIAS name used in the DatabaseName Property for dataset components such as
TTable, TQuery, TStoredProc.

5. Select STANDARD as the Driveer Name.

6. Click on the Defaults Button. This will automatically add a PATH= in
the Parameter Overrides section.

7. Set the PATH= to C:\DELPHI\DEMOS\DATA (PATH=C:\DELPHI\DEMOS\DATA)

8. Click the OK button to close the Database Dialog.

9. Set the TTable DatabaseName Property to 'MyNewAlias'.

10. Set the TDataSource's DataSet Property to 'Table1'.

11. Set the DBGrid's DataSource Property to 'DataSource1'.

12. Place the following code inside of the TButton's OnClick event./}

procedure TForm1.Button1Click(Sender: TObject);
begin
Table1.TableName := 'CUSTOMER';
Table1.Active := True;
end;

{/13. Run the application./}


{/*** If you want an alternative way to steps 3 - 11, place the following
code inside of the TButton's OnClick event./}

procedure TForm1.Button1Click(Sender: TObject);
begin
Database1.DatabaseName := 'MyNewAlias';
Database1.DriverName := 'STANDARD';
Database1.Params.Clear;
Database1.Params.Add('PATH=C:\DELPHI\DEMOS \DATA');
Table1.DatabaseName := 'MyNewAlias';
Table1.TableName := 'CUSTOMER';
Table1.Active := True;
DataSource1.DataSet := Table1;
DBGrid1.DataSource := DataSource1;
end;

{/Example #2: Use of a INTERBASE database/}

{/1. Create a New Project.

2. Place the following components on the form: - TDatabase, TQuery,
TDataSource, TDBGrid, and TButton.

3. Double-click on the TDatabase component or choose Database Editor from
the TDatabase SpeedMenu to launch the Database Property editor.

4. Set the Database Name to 'MyNewAlias'. This name will serve as your
ALIAS name used in the DatabaseName Property for dataset components such as
TTable, TQuery, TStoredProc.

5. Select INTRBASE as the Driver Name.

6. Click on the Defaults Button. This will automatically add the
following entries in the Parameter Overrides section.

SERVER NAME=IB_SERVEER:/PATH/DATABASE.GDB
USER NAME=MYNAME
OPEN MODE=READ/WRITE
SCHEMA CACHE SIZE=8
LANGDRIVER=
SQLQRYMODE=
SQLPASSTHRU MODE=NOT SHARED
SCHEMA CACHE TIME=-1
PASSWORD=

7. Set the following parameters

SERVER NAME=C:\IBLOCAL\EXAMPLES\EMPLOYEE.GDB
USER NAME=SYSDBA
OPEN MODE=READ/WRITE
SCHEMA CACHE SIZE=8
LANGDRIVER=
SQLQRYMODE=
SQLPASSTHRU MODE=NOT SHARED
SCHEMA CACHE TIME=-1
PASSWORD=masterkey

8. Set the TDatabase LoginPrompt Property to 'False'. If you supply the
PASSWORD in the Parameter Overrides section and set the LoginPrompt to
'False', you will not be prompted for the
password when connecting to the database. WARNING: If an incorrect
password in entered in the Parameter Overrides section and LoginPrompt is
set to 'False', you are not prompted by the Password dialog to re-enter a
valid password.

9. Click the OK button to close the Database Dialog.

10. Set the TQuery DatabaseName Property to 'MyNewAliias'.

11. Set the TDataSource's DataSet Property to 'Query1'.

12. Set the DBGrid's DataSource Property to 'DataSource1'.

13. Place the following code inside of the TButton's OnClick event./}

procedure TForm1.Button1Click(Sender: TObject);
begin
Query1.SQL.Clear;
Query1.SQL.Add('SELECT DISTINCT * FROM CUSTOMER C, SALES S
WHERE(S.CUST_NO = C.CUST_NO)
ORDER BY C.CUST_NO, C.CUSTOMER');
Query1.Active := True;
end;

{/14. Run the application./}


{/Example #3: User-defined Alias Configuration/}

{/This example brings up a input dialog and prompts the user to enter the
directory to which the ALIAS is to be configured to.

The directory, servername, path, database name, and other neccessary Alias
parameters can be read into the application from use of an input dialog or
.INI file.

1. Follow the steps (1-11) in Example #1.

2. Place the following code inside of the TButton's OnClick event./}

procedure TForm1.Buttton1Click(Sender: TObject);
var
NewString: string;
ClickedOK: Boolean;
begin
NewString := 'C:\';
ClickedOK := InputQuery('Database Path',
'Path: --> C:\DELPHI\DEMOS\DATA', NewString);
if ClickedOK then
begin
Database1.DatabaseName := 'MyNewAlias';
Database1.DriverName := 'STANDARD';
Database1.Params.Clear;
Database1.Params.Add('Path=' + NewString);
Table1.DatabaseName := 'MyNewAlias';
Table1.TableName := 'CUSTOMER';
Table1.Active := True;
DataSource1.DataSet := Table1;
DBGrid1.DataSource := DataSource1;
end;
end;

//3. Run the Application

[پسر خاک]

ایجاد یک جدول مجازی
unit Inmem;

interface

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

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

implementation

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

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

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

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

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

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

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

end.

[پسر خاک]

ایجاد سریع یک جدول پارادوکس به کمک کد
procedure TForm1.Button1Click(Sender: TObject);
begin
with Query1 do
begin
DatabaseName := 'DBDemos';
with SQL do
begin
Clear;
{/
CREATE TABLE creates a table with the given name in the
current database

CREATE TABLE erzeugt eine Tabelle mit einem angegebenen
Namen in der aktuellen Datenbank
/}
Add('CREATE TABLE "PDoxTbl.db" (ID AUTOINC,');
Add('Name CHAR(255),');
Add('PRIMARY KEY(ID))');
{/
Call ExecSQL to execute the SQL statement currently
assigned to the SQL property.

Mit ExecSQL wird die Anweisung ausgeführt,
welche aktuell in der Eigenschaft SQL enthalten ist.
/}
ExecSQL;
Clear;
Add('CREATE INDEX ByName ON "PDoxTbl.db" (Name)');
ExecSQL;
end;
end;
end;

[پسر خاک]

ایجاد یک اتصال DBExpress در زمان اجرا
procedure TVCLScanner.PostUser(const Email, FirstName, LastName: WideString);
var
Connection: TSQLConnection;
DataSet: TSQLDataSet;
begin
Connection := TSQLConnection.Create(nil);
with Connection do
begin
ConnectionName := 'VCLScanner';
DriverName := 'INTERBASE';
LibraryName := 'dbexpint.dll';
VendorLib := 'GDS32.DLL';
GetDriverFunc := 'getSQLDriverINTERBASE';
Params.Add('User_Name=SYSDBA');
Params.Add('Password=masterkey');
Params.Add('Database=milo2:D:\frank\we bservices\umlbank.gdb');
LoginPrompt := False;
Open;
end;
DataSet := TSQLDataSet.Create(nil);
with DataSet do
begin
SQLConnection := Connection;
CommandText := Format('INSERT INTO kings VALUES("%s","%s","%s")',
[Email, FirstN, LastN]);
try
ExecSQL;
except
end;
end;
Connection.Close;
DataSet.Free;
Connection.Free;
end;

[پسر خاک]

رنگ آمیزی یک TDBGrid
procedure TForm1.ColorGrid(dbgIn: TDBGrid; qryIn: TQuery; const Rect: TRect;
DataCol: Integer; Column: TColumn;
State: TGridDrawState);
var
iValue: LongInt;
begin
// color only the first field
// nur erstes Feld einf&auml;rben
if (DataCol = 0) then
begin
// Check the field value and assign a color
// Feld-Wert prüfen und entsprechende Farbe w&auml;hlen
iValue := qryIn.FieldByName('HINWEIS_COLOR').AsInteg er;
case iValue of
1: dbgIn.Canvas.Brush.Color := clGreen;
2: dbgIn.Canvas.Brush.Color := clLime;
3: dbgIn.Canvas.Brush.Color := clYellow;
4: dbgIn.Canvas.Brush.Color := clRed;
end;
// Draw the field
// Feld zeichnen
dbgIn.DefaultDrawColumnCell(Rect, DataCol, Column, State);
end;
end;

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
ColorGrid(DBGrid1, Query1, Rect, DataCol, Column, State);
end;

[پسر خاک]

خواندن تمام رکوردهای یک جدول در TstringGrid
Loading millions of records into a stringlist can be very slow /}

procedure TForm1.SlowLoadingIntoStringList(StringList: TStringList);
begin
StringList.Clear;
with SourceTable do
begin
Open;
DisableControls;
try
while not EOF do
begin
StringList.Add(FieldByName('OriginalData').AsStrin g);
Next;
end;
finally
EnableControls;
Close;
end;
end;
end;

{/ This is much, much faster /}
procedure TForm1.QuickLoadingIntoStringList(StringList: TStringList);
begin
with CacheTable do
begin
Open;
try
StringList.Text := FieldByName('Data').AsString;
finally
Close;
end;
end;
end;

{/ How can this be done?

In Microsoft SQL Server 7, you can write a stored procedure that updates every night
a cache table that holds all the data you want in a single column and row.
In this example, you get the data from a SourceTable and put it all in a Cachetable.
The CacheTable has one blob column and must have only one row.
Here it is the SQL code: /}


Create Table CacheTable
(Data Text NULL)
GO

Create

procedure PopulateCacheTable as
begin
set NOCOUNT on
DECLARE @ptrval binary(16), @Value varchar(600) -
- a good Value for the expected maximum Length
- - You must set 'select into/bulkcopy' option to True in order to run this sp
DECLARE @dbname nvarchar(128)
set @dbname = db_name()
EXEC sp_dboption @dbname, 'select into/bulkcopy', 'true'
- - Declare a cursor
DECLARE scr CURSOR for
SELECT OriginalData + char(13) + char(10) - - each line in a TStringList is
separated by a #13#10
FROM SourceTable
- - The CacheTable Table must have only one record
if EXISTS (SELECT * FROM CacheTable)
Update CacheTable set Data = ''
else
Insert CacheTable VALUES('')
- - Get a Pointer to the field we want to Update
SELECT @ptrval = TEXTPTR(Data) FROM CacheTable

Open scr
FETCH Next FROM scr INTO @Value
while @ @FETCH_STATUS = 0
begin - - This UPDATETEXT appends each Value to the
end
of the blob field
UPDATETEXT CacheTable.Data @ptrval NULL 0 @Value
FETCH Next FROM scr INTO @Value
end
Close scr
DEALLOCATE scr
- - Reset this option to False
EXEC sp_dboption @dbname, 'select into/bulkcopy', 'false'
end
GO

{/ You may need to increase the BLOB SIZE parameter if you use BDE /}

[مهدی کرامتی]

بحثهای آف تاپیک به اینجا (http://www.barnamenevis.org/forum/viewtopic.php?t=11507) منتقل شد.

[SalarSoft]

جلوگیری از لیست توماری شدن منو:
Procedure BreakMoreMenu(fSubMenu:TmenuItem;
fMode:TMenuBreak=mbBarBreak);
var
fMnuHeight:Integer;
ScrHeight:Integer;
Count:integer;
i:integer;
items:integer;
begin
fMnuHeight:=GetSystemMetrics(SM_CYMENU&#41 ;;
If fMnuHeight<1 then
fMnuHeight:=4
else
fMnuHeight:=fMnuHeight+3;
ScrHeight:=(screen.Height)-(fMnuHeight *5) ;
Count:=(ScrHeight div fMnuHeight);//Menus in screen
items:=0;
for i:=0 to fSubMenu.Count-1 do begin
If items>=Count then begin
fSubMenu.Items[i].Break:=fMode;
items:=0;
end;
items:=items+1;
end;
end;

[SalarSoft]

به چرخش در آوردن متن:
procedure AngleTextOut(Acanvas:Tcanvas;Angle,x,y&#58 ;integer;Str:String);
var
LogRec:TLogFont;
OldFontHandle,
NewFontHandle:Hfont;
begin
GetObject(Acanvas.Font.Handle,SizeOf(LogRe c),Addr(LogRec));
LogRec.lfEscapement:=Angle*10;
NewFontHandle:=CreateFontIndirect(logRec&# 41;;
OldFontHandle:=SelectObject(Acanvas.handle ,NewFontHandle);
ACanvas.TextOut(x,y,Str);
NewFontHandle:=SelectObject(Acanvas.handle ,OldFontHandle);
DeleteObject(NewFontHandle);
end;

[SalarSoft]

یافتن فایل در تمام شاخه و زیر شاخه هایش:

اصلاح شد: با نام فایل هایی که فاصله داشتن مشکل داشت!
function FindFile(Path,Files:String):TStrin gs;
Var
Dirs,Fill:String;
IO,len,i:Integer;
Search:TsearchRec;
Begin
Result:=TStringList.Create;
If Path='' then exit;
//While Pos(';',files)>0 do
// Files[Pos(';',Files)]:=' '; //****
Dirs:='';
If Path[Length(Path)]='\' then
Delete(path,length(path),1);
Repeat
I:=Length(Files);
Repeat
Fill:='';
While (I>0) and (files[I]<>';') do //' ') do //******
Begin
Fill:=files[I]+Fill;
I:=i-1;
end;
I:=i-1;
IO:=findFirst(path+'\'+fill,faAnyFile-faDirectory,Search);
While Io=0 do
Begin
If (search.Name<>'.') and (search.name<>'..') then
Result.Add(path+'\'+Search.name);
IO:=FindNext(Search);
end;
FindClose(search);
until I<1;
IO:=FindFirst(Path+'\*.*',faAnyFile,Search );
While IO=0 do
Begin
If (search.Name<>'.') and (search.name<>'..') and (search.Attr and FaDirectory>0) then
Dirs:=Dirs+Path+'\'+Search.Name+#13;
Io:=FindNext(search);
end;
FindClose(search);
Len:=length(Dirs)-1;
Io:=len;
If Len>0 then
Begin
While (IO>0) and (Dirs[IO]<>#13) do Io:=IO-1;
Path:=Copy(Dirs,IO+1,Len-IO);
SetLength(Dirs,IO);
end;
Until(len<0);
end;

[SalarSoft]

بدست آوردن Handle یک پروسه با نام فایلش:
const
TH32CS_SNAPPROCESS = $00000002;
SYNCHRONIZE = $00100000;
PROCESS_TERMINATE = $0001;

type
TProcessEntry32 = packed record
dwSize: DWORD;
cntUsage: DWORD;
th32ProcessID: DWORD; // this process
th32DefaultHeapID: DWORD;
th32ModuleID: DWORD; // associated exe
cntThreads: DWORD;
th32ParentProcessID: DWORD; // this process's parent process
pcPriClassBase: Longint; // Base priority of process's threads
dwFlags: DWORD;
szExeFile: array[0..MAX_PATH - 1] of Char;// Path
end;

function CreateToolhelp32Snapshot (dwFlags, th32ProcessID: DWORD): THandle stdcall;external kernel32 name 'CreateToolhelp32Snapshot';
function Process32First(hSnapshot: THandle; var lppe: TProcessEntry32): BOOL stdcall;external kernel32 name 'Process32First';
function Process32Next(hSnapshot: THandle; var lppe: TProcessEntry32): BOOL stdcall;external kernel32 name 'Process32Next';
function OpenProcess(dwDesiredAccess: DWORD; bInheritHandle: BOOL; dwProcessId: DWORD): THandle; stdcall;external kernel32 name 'OpenProcess';
function TerminateProcess(hProcess: THandle; uExitCode: UINT): BOOL; stdcall;external kernel32 name 'TerminateProcess';

Function FindInProcess(name:string;SearchInOther&#5 8;Boolean;var FileName:string):THandle;
var
fData: TProcessEntry32;
fHandler: THandle;
fFileN:string;

Function SearchProcess:THandle;
begin
fFileN:=fData.szExeFile;
fFileN:=extractFileName(fFileN);
result:=0;
name:=LowerCase(name);
fFileN:=LowerCase(fFileN);
If name=fFileN then
Result:=OpenProcess(SYNCHRONIZE or PROCESS_TERMINATE, False,fData.th32ProcessID)
else
If SearchInOther then
If pos(name,fFileN)<>0 then
Result:=OpenProcess(SYNCHRONIZE or PROCESS_TERMINATE, False,fData.th32ProcessID);
If Result<>0 then
FileName:=fData.szExeFile ;
//result:=fData.th32ProcessID;
end;

begin
fData.dwSize := SizeOf(fData);
fHandler := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
result:=0;
FileName:='';
try
if Process32First(fHandler, fData) then
begin
result:=SearchProcess;
If result<>0 then exit;

while Process32Next(fHandler, fData) do
begin
result:=SearchProcess;
If result<>0 then exit;
end;
end;
finally
CloseHandle(fHandler);
end;

end;

[SalarSoft]

فرم شفاف شده و فقط کنترل ها نشان داده شود!:
procedure TranparentForm(Form:Tform;HaveCaption,Have Menu:Boolean);
var
frmRegion,
tempRegion:HRGN;
i:Integer;
Arect:Trect;
begin
frmRegion:=0;
For i:=0 to Form.controlcount -1 do
begin
Arect:=Form.controls[i].BoundsRect;
Offsetrect(Arect,Form.ClientOrigin.x-Form.left,Form.ClientOrigin.y-Form.top);
tempRegion:=CreateRectRgnIndirect(Arect&#4 1;;
if frmRegion=0 then
begin
frmRegion:=tempRegion;
end
else
Begin
CombineRgn(frmRegion,frmRegion,TempRegion,RGN_ OR);
DeleteObject(tempRegion);
end;
end;
tempRegion:=0;
If HaveCaption and HaveMenu then
tempRegion:= CreateRectRgn(0,0,Form.Width,
GetSystemMetrics(SM_CYCAPTION)+
GetSystemMetrics(SM_CYSIZEFRAME)+
GetSystemMetrics(SM_CYMENU)*ORD(Form.M enu<>nil));
If (HaveCaption=false) and HaveMenu then
tempRegion:= CreateRectRgn(0,GetSystemMetrics(SM_CYCAPT ION)+GetSystemMetrics(SM_CYSIZEFRAmE), Form.Width,
(GetSystemMetrics(SM_CYSIZEFRAmE)+GetS ystemMetrics(SM_CYMENU)*ORD(Form.Menu& lt;>nil))+GetSystemMetrics(SM_CYCAPTIO N));
If HaveCaption and (HaveMenu=false) then
tempRegion:= CreateRectRgn(0,0,Form.Width,
GetSystemMetrics(SM_CYCAPTION)+
GetSystemMetrics(SM_CYSIZEFRAmE));
If (HaveCaption=false) and (HaveMenu=false) then
tempRegion:= CreateRectRgn(0,0,Form.Width,0);

CombineRgn(frmregion,frmregion,tempregion,rgn_ or);
Deleteobject(tempregion);
setwindowrgn(Form.handle,frmregion,true);
end;

[SalarSoft]

مخفی و ظاهر ساختن عنوان فرم:
Procedure Hide_ShowCaption(fForm:Tform;fHide:Boo lean);
var
Save:LongInt;
Begin
If fform.BorderStyle=bsnone then exit;
Save:=GetWindowLong(fform.Handle,gwl_Style );
If Fhide then begin
If (Save and Ws_Caption )=ws_Caption then begin
Case fform.BorderStyle of
bsSizeable,
bsSingle:
SetWindowLong(fform.Handle,gwl_style,
save and (not (ws_Caption)) or ws_Border);
bsDialog:
SetWindowLong(fform.Handle,gwl_style,
save and (not (ws_Caption)) or DS_MODALFRAME or ws_DlgFrame);
end;
fform.Height:= fform.Height-GetSystemMetrics(sm_CyCaption);
fform.Refresh;
end;
end else begin
If (Save and Ws_Caption )=ws_Caption then begin
Case fform.BorderStyle of
bsSizeable,
bsSingle:
SetWindowLong(fform.Handle,gwl_style,
save or ws_Caption or ws_Border);
bsDialog:
SetWindowLong(fform.Handle,gwl_style,
save or ws_Caption or DS_MODALFRAME or ws_DlgFrame);
end;
fform.Height:= fform.Height+GetSystemMetrics(sm_CyCaption&#41 ;;
fform.Refresh;
end;
end;
end;

[SalarSoft]

خذف یا انتقال فایل در حال اجرا توسط برنامه دیگر ( فقط در ویندوز نوع NT):
function MoveDelFileReboot(Fileanme,New:String;fMov e:Boolean=true):Boolean;
begin
If fMove then
result:=movefileEx(Pchar(Fileanme) ,Pchar(new),MoveFile_Replace_Existing or MoveFile_Delay_Until_Reboot)
else
Result:=movefileEx(Pchar(Fileanme) ,nil,MoveFile_Replace_Existing or MoveFile_Delay_Until_Reboot);
end;

[SalarSoft]

تعیین وضعیت مانیتور:
procedure MonitorState(HWnd:HWnd;StandBy:Boolean );
begin
If StandBy then
sendMessage(HWnd,WM_SYSCOMMAND,SC_MonitorPower ,0)
else
sendMessage(HWnd,WM_SYSCOMMAND,SC_MonitorPower ,-1);
end;

[Mbr]

با سلام
طریقه بوت کردن ویندوز 2000 و XP برای دوستان عزیز
function MyExitWindows(RebootParam: Longword): Boolean ;
var
TTokenHd: THandle;
TTokenPvg: TTokenPrivileges;
cbtpPrevious: DWORD;
rTTokenPvg: TTokenPrivileges;
pcbtpPreviousRequired: DWORD;
tpResult: Boolean;
const
SE_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, SE_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;



procedure TForm1.Button1Click(Sender: TObject);
begin
MyExitWindows(EWX_REBOOT or EWX_FORCE);
end;

[Mbr]

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


ShellExecute(Handle, 'open', 'rundll',
'shell32.dll,SHHelpShortcuts_RunDLL AddPrinter', '', SW_SHOWNORMAL);

[Mbr]

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



Library TheHook;

uses
Windows, Messages, SysUtils;

{Define a record for recording and passing information process wide}
type
PHookRec = ^ THookRec;
THookRec = Packed Record
TheHookHandle: HHOOK;
TheAppWinHandle: HWnd;
TheCtrlWinHandle: HWnd;
TheKeyCount: DWord;
end;

var
hObjHandle : THandle; {Variable for the file mapping object}
lpHookRec : PHookRec;
{Pointer to our hook record}
procedure MapFileMemory (dwAllocSize: DWord);
begin { MapFileMemory }
{Create a process wide memory mapped variable}
hObjHandle := CreateFileMapping ($FFFFFFFF, Nil, PAGE_READWRITE, 0,
dwAllocSize, 'HookRecMemBlock');
if (hObjHandle = 0) then
begin
MessageBox (0, 'Hook DLL', 'Could not create file map object', mb_Ok);
exit
end { (hObjHandle = 0) };
{Get a pointer to our process wide memory mapped variable}
lpHookRec := MapViewOfFile (hObjHandle, FILE_MAP_WRITE, 0, 0, dwAllocSize);
if (lpHookRec = Nil) then
begin
CloseHandle (hObjHandle);
MessageBox (0, 'Hook DLL', 'Could not map file', mb_Ok);
exit
end { (lpHookRec = Nil) }
end; { MapFileMemory }


procedure UnMapFileMemory;
begin { UnMapFileMemory }
{Delete our process wide memory mapped variable}
if (lpHookRec &lt;> Nil) then
begin
UnMapViewOfFile (lpHookRec);
lpHookRec := Nil
end { (lpHookRec &lt;> Nil) };
if (hObjHandle > 0) then
begin
CloseHandle (hObjHandle);
hObjHandle := 0
end { (hObjHandle > 0) }
end; { UnMapFileMemory }


function GetHookRecPointer : pointer
stdcall;
begin { GetHookRecPointer }
{Return a pointer to our process wide memory mapped variable}
Result := lpHookRec
end; { GetHookRecPointer }


{The function that actually processes the keystrokes for our hook}
function KeyBoardProc (code: Integer; wParam: Integer; lParam: Integer) :
Integer;
stdcall;
var
KeyUp : bool;
{Remove comments for additional functionability
IsAltPressed : bool;
IsCtrlPressed : bool;
IsShiftPressed : bool;
}
begin { KeyBoardProc }
Result := 0;

Case code Of
HC_ACTION:
begin
{We trap the keystrokes here}
{Is this a key up message?}
KeyUp := ((lParam and (1 shl 31)) &lt;> 0);

(*Remove comments for additional functionability
{Is the Alt key pressed}
if ((lParam and (1 shl 29)) &lt;> 0) then begin
IsAltPressed := TRUE;
end else begin
IsAltPressed := FALSE;
end;

{Is the Control key pressed}
if ((GetKeyState(VK_CONTROL) and (1 shl 15)) &lt;> 0) then begin
IsCtrlPressed := TRUE;
end else begin
IsCtrlPressed := FALSE;
end;

{if the Shift key pressed}
if ((GetKeyState(VK_SHIFT) and (1 shl 15)) &lt;> 0) then begin
IsShiftPressed := TRUE;
end else begin
IsShiftPressed := FALSE;
end;
*)
{if KeyUp then increment the key count}
if (KeyUp &lt;> false) then
begin
inc (lpHookRec^.TheKeyCount)
end { (KeyUp &lt;> false) };

Case wParam Of
{Was the enter key pressed?}
VK_RETURN:
begin
{if KeyUp}
if (KeyUp &lt;> false) then
begin
{Post a bogus message to the window control in our app}
PostMessage (lpHookRec^.TheCtrlWinHandle, WM_KEYDOWN, 0, 0);
PostMessage (lpHookRec^.TheCtrlWinHandle, WM_KEYUP, 0, 0)
end { (KeyUp &lt;> false) };
{if you wanted to swallow the keystroke then return -1}
{else if you want to allow the keystroke then return 0}
Result := 0;
exit
end; {VK_RETURN}
{if the left arrow key is pressed then lets play a joke!}
VK_LEFT:
begin
{if KeyUp}
if (KeyUp &lt;> false) then
begin
{Create a UpArrow keyboard event}
keybd_event (VK_RIGHT, 0, 0, 0);
keybd_event (VK_RIGHT, 0, KEYEVENTF_KEYUP, 0)
end { (KeyUp &lt;> false) };
{Swallow the keystroke}
Result := -1;
exit
end; {VK_LEFT}
end { case wParam }; {case wParam}
{Allow the keystroke}
Result := 0
end; {HC_ACTION}
HC_NOREMOVE:
begin
{This is a keystroke message, but the keystroke message}
{has not been removed from the message queue, since an}
{application has called PeekMessage() specifying PM_NOREMOVE}
Result := 0;
exit
end;
end { case code }; {case code}
if (code &lt; 0) then
{Call the next hook in the hook chain}
Result := CallNextHookEx (lpHookRec^.TheHookHandle, code, wParam, lParam)
end; { KeyBoardProc }


procedure StartKeyBoardHook
stdcall;
begin { StartKeyBoardHook }
{if we have a process wide memory variable}
{and the hook has not already been set...}
if ((lpHookRec &lt;> Nil) and (lpHookRec^.TheHookHandle = 0)) then
begin
{Set the hook and remember our hook handle}
lpHookRec^.TheHookHandle := SetWindowsHookEx (WH_KEYBOARD, @KeyBoardProc,
HInstance, 0)
end { ((lpHookRec &lt;> Nil) and (lpHookRec^.TheHookHandle = 0)) }
end; { StartKeyBoardHook }


procedure StopKeyBoardHook
stdcall;
begin { StopKeyBoardHook }
{if we have a process wide memory variable}
{and the hook has already been set...}
if ((lpHookRec &lt;> Nil) and (lpHookRec^.TheHookHandle &lt;> 0)) then
begin
{Remove our hook and clear our hook handle}
if (UnHookWindowsHookEx (lpHookRec^.TheHookHandle) &lt;> false) then
begin
lpHookRec^.TheHookHandle := 0
end { (UnHookWindowsHookEx (lpHookRec^.TheHookHandle) &lt;> false) }
end { ((lpHookRec &lt;> Nil) and (lpHookRec^.TheHookHandle &lt;> 0)) }
end; { StopKeyBoardHook }


procedure DllEntryPoint (dwReason: DWord);
begin { DllEntryPoint }
Case dwReason Of
Dll_Process_Attach:
begin
{if we are getting mapped into a process, then get}
{a pointer to our process wide memory mapped variable}
hObjHandle := 0;
lpHookRec := Nil;
MapFileMemory (sizeof (lpHookRec^))
end;
Dll_Process_Detach:
begin
{if we are getting unmapped from a process then, remove}
{the pointer to our process wide memory mapped variable}
UnMapFileMemory
end;
end { case dwReason }
end; { DllEntryPoint }


Exports
KeyBoardProc name 'KEYBOARDPROC',
GetHookRecPointer name 'GETHOOKRECPOINTER',
StartKeyBoardHook name 'STARTKEYBOARDHOOK',
StopKeyBoardHook name 'STOPKEYBOARDHOOK';

begin
{Set our Dll's main entry point}
DLLProc := @DllEntryPoint;
{Call our Dll's main entry point}
DllEntryPoint (Dll_Process_Attach)
end.

[Mbr]

این هم یکی دیگر
کد خطا های زمان اجرای دلفی


1 Invalid function number
2 File not found
3 Path not found
4 Too many open files
5 File access denied
6 Invalid file handle
12 Invalid file access code
15 Invalid drive number
16 Cannot remove current directory
17 Cannot rename across drives
100 Disk read error
101 Disk write error
102 File not assigned
103 File not open
104 File not open for input
105 File not open for output
106 Invalid numeric format
200 Division by zero
201 Range check error
202 Stack overflow error
203 Heap overflow error
204 Invalid pointer operation
205 Floating point overflow
206 Floating point underflow
207 Invalid floating point operation
210 Object not initialized
211 Call to abstract method
212 Stream registration error
213 Collection index out of range
214 Collection overflow error
215 Arithmetic overflow error
216 General protection fault

[SalarSoft]

نشان دادن تمام گزینه های منو در روی دکمه برنامه در Taskbar:

در حالت عادی سه گزینه در منو وجود داره که با این روش همه گزینه های استاندارد نشان داده خواهند شد!! :shock:

فقط همین:
GetSystemMenu(Application.handle,true);

در حقیقت این دستور با خوارج کردن کنترل منو ها از دست برنامه این کار را انجام می دهد :shock:

[Mbr]

با سلام خدمت دوستان عزیز
و با تشکر ا کد های بسیار جذاب دوستان
زمان آخرین دسترسی به یک فایل



function GetFileLastAccessTime(
sFileName : string ) : TDateTime;
var
ffd : TWin32FindData;
dft : DWord;
lft : TFileTime;
h : THandle;
begin
//
// get file information
h := Windows.FindFirstFile(
PChar(sFileName), ffd);
if(INVALID_HANDLE_VALUE &lt;> h)then
begin
//
// we're looking for just one file,
// so close our "find"
Windows.FindClose( h );
//
// convert the FILETIME to
// local FILETIME
FileTimeToLocalFileTime(
ffd.ftLastAccessTime, lft );
//
// convert FILETIME to
// DOS time
FileTimeToDosDateTime(lft,
LongRec(dft).Hi, LongRec(dft).Lo);
//
// finally, convert DOS time to
// TDateTime for use in Delphi's
// native date/time functions
Result := FileDateToDateTime(dft);
end;
end;

مثالی در رابطه با برنامه بالا


MessageDlg(
'c:\config.sys was last accessed on ' +
DateTimeToStr(
GetFileLastAccessTime( 'c:\config.sys' ) ),
mtInformation, [mbOk], 0 );

[SalarSoft]

فهمیدن اینکه آیا یک ایمیل از نظر املایی درست است یا نه!
اصلاح شد: اکنون ایمیلهای یا قالب<span dir=ltr> email.mail@Site.com</span>رو پشتیبانی میکنه!
Function IsValidMail(mail:string):Boolean;
var
i,Dot,AtSine:longInt;
tmpMail:string;
ch:char;
begin
result:=false;
If mail='' then exit;
tmpMail:=lowercase(mail);
AtSine:=pos('@',tmpMail);
Dot:=PosEx('.',tmpMail,atsine);
If Dot>AtSine then begin
for i:=1 to length(tmpMail) do begin
ch:=(tmpMail[i]);
If not( (ch in ['a'..'z']) or (ch in ['0'..'9']) or (ch in ['-','_','.']) ) then
begin
Result:=false;
Exit;
end;
end;
Result:=True;
end;
end;

[SalarSoft]

حذف داده های تکراری از لیست:Procedure RemoveDuplicateItem(SrcList,DestList:TStri ngList);
var
i:cardinal;
index:longint;
str:string;
begin
If not assigned(SrcList) then
SrcList := TStringList.Create;
If not assigned(DestList) then
DestList := TStringList.Create;
SrcList.Sort;
for i:=0 to SrcList.Count-1 do begin
str:=SrcList.Strings[i];
DestList.Sort;
index:=0;
If not DestList.Find(str,index) then begin
DestList.Insert(index,str);
end;
end;
end;

[BOB]

سلام
ساده ترین راه برای باز کردن یک فایل توسط برنامه مرتبط با آن :
WinExec('rundll32.exe url.dll,FileProtocolHandler '+[filePath] ,SW_NORMAL);

ظاهر شدن پنجره OpenWith برای یک فایل :
WinExec('rundll32.exe shell32.dll,OpenAs_RunDLL '+[filePath] ,SW_NORMAL);
چاپ یک فایل HTML :
WinExec('rundll32.exe MSHTML.DLL,PrintHTML '+[filePath] ,SW_NORMAL);

[SalarSoft]

ایجاد سایه در زیر فرم هاtype
Tform1 = class(TForm)
private
{/ Private declarations /}
Procedure CreateParams(Var Params: TCreateParams); override;
end;

implementation

{/$R *.DFM/}

procedure Tform1.CreateParams(var Params: TCreateParams);
begin
inherited;
if CheckWin32Version(5, 1) then
Params.WindowClass.Style := Params.WindowClass.style or CS_DROPSHADOW;
end;

[SalarSoft]

پیدا کردن یک پروسه در پروسه های دیگر با نام فایلش

با استفاده از تابع FindInProcessEx می توانید هندل (Handle) یک پروسه مانند با آدرس فایل آن بدست بیاورید.
توجه: این تابع بر روی پروسه های سیستمی ویندوز های نوع NT مانند NT ، 2000 و XP کار نخواهد کرد. برخی پروسه های سیستمی عبارتند از mdm.exe , inetinfo.exe , svhost.exe و...

type
DWORD = Longword;
BOOL=Boolean;
UINT=Cardinal;

const
TH32CS_SNAPHEAPLIST = $00000001;
TH32CS_SNAPPROCESS = $00000002;
TH32CS_SNAPTHREAD = $00000004;
TH32CS_SNAPMODULE = $00000008;
TH32CS_INHERIT = $80000000;
TH32CS_SNAPALL = TH32CS_SNAPHEAPLIST or TH32CS_SNAPPROCESS or
TH32CS_SNAPTHREAD or TH32CS_SNAPMODULE;

MAX_MODULE_NAME32 = 255;
SYNCHRONIZE = $00100000;
PROCESS_TERMINATE = $0001;
MAX_PATH = 260;
kernel32 = 'kernel32.dll';

type
TProcessEntry32 = packed record
dwSize: DWORD;
cntUsage: DWORD;
th32ProcessID: DWORD; // this process
th32DefaultHeapID: DWORD;
th32ModuleID: DWORD; // associated exe
cntThreads: DWORD;
th32ParentProcessID: DWORD; // this process's parent process
pcPriClassBase: Longint; // Base priority of process's threads
dwFlags: DWORD;
szExeFile: array[0..MAX_PATH - 1] of Char;// Path
end;

TModuleEntry32 = record
dwSize: DWORD;
th32ModuleID: DWORD; // This module
th32ProcessID: DWORD; // owning process
GlblcntUsage: DWORD; // Global usage count on the module
ProccntUsage: DWORD; // Module usage count in th32ProcessID's context
modBaseAddr: PBYTE; // Base address of module in th32ProcessID's context
modBaseSize: DWORD; // Size in bytes of module starting at modBaseAddr
hModule: HMODULE; // The hModule of this module in th32ProcessID's context
szModule: array[0..MAX_MODULE_NAME32] of Char;
szExePath: array[0..MAX_PATH - 1] of Char;
end;

function CreateToolhelp32Snapshot (dwFlags, th32ProcessID: DWORD): THandle stdcall;external kernel32 name 'CreateToolhelp32Snapshot';
function Process32First(hSnapshot: THandle; var lppe: TProcessEntry32): BOOL stdcall;external kernel32 name 'Process32First';
function Process32Next(hSnapshot: THandle; var lppe: TProcessEntry32): BOOL stdcall;external kernel32 name 'Process32Next';
function OpenProcess(dwDesiredAccess: DWORD; bInheritHandle: BOOL; dwProcessId: DWORD): THandle; stdcall;external kernel32 name 'OpenProcess';
function TerminateProcess(hProcess: THandle; uExitCode: UINT): BOOL; stdcall;external kernel32 name 'TerminateProcess';

function Module32First(hSnapshot: THandle; var lpme: TModuleEntry32): BOOL stdcall;external kernel32 name 'Module32First';
function Module32Next(hSnapshot: THandle; var lpme: TModuleEntry32): BOOL stdcall;external kernel32 name 'Module32Next';

Function FindInProcess(name:string;SearchInOther&#5 8;Boolean;var FileName:string):THandle;
Function FindInProcessEx(name:string;SearchInOther& #58;Boolean;var FileName:string):THandle;
Function GetProcessFilePath(name:string;ProcessID&# 58;DWORD;findexe:boolean):string;

implementation

Function FindInProcess(name:string;SearchInOther&#5 8;Boolean;var FileName:string):THandle;
var
fData: TProcessEntry32;
fHandler: THandle;
fFileN:string;

Function SearchProcess:THandle;
begin
fFileN:=fData.szExeFile;
fFileN:=extractFileName(fFileN);
result:=0;
name:=LowerCase(name);
fFileN:=LowerCase(fFileN);
If name=fFileN then //SYNCHRONIZE or PROCESS_TERMINATE
//Result:=OpenProcess(PROCESS_ALL_ACCESS or PROCESS_TERMINATE or SYNCHRONIZE , False,fData.th32ProcessID)
Result:=OpenProcess(SYNCHRONIZE or PROCESS_TERMINATE , False,fData.th32ProcessID)
else begin
If SearchInOther then
If pos(name,fFileN)<>0 then begin
//Result:=OpenProcess(PROCESS_ALL_ACCESS or SYNCHRONIZE or PROCESS_TERMINATE, False,fData.th32ProcessID);
Result:=OpenProcess(SYNCHRONIZE or PROCESS_TERMINATE, False,fData.th32ProcessID);
FileName:=fData.szExeFile ;
end;
end;
end;

begin
fData.dwSize := SizeOf(fData);
fHandler := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
result:=0;
FileName:='';
try
if Process32First(fHandler, fData) then
begin
result:=SearchProcess;
If result<>0 then exit;

while Process32Next(fHandler, fData) do
begin
result:=SearchProcess;
If result<>0 then exit;
end;
end;
finally
CloseHandle(fHandler);
end;

end;

Function FindInProcessEx(name:string;SearchInOther& #58;Boolean;var FileName:string):THandle;
var
fData: TProcessEntry32;
fHandler: THandle;
fFileN:string;

Function SearchProcess:THandle;
begin
fFileN:=fData.szExeFile;
fFileN:=extractFileName(fFileN);
result:=0;
name:=LowerCase(name);
fFileN:=LowerCase(fFileN);
If name=fFileN then
Result:=OpenProcess(SYNCHRONIZE or PROCESS_TERMINATE , False,fData.th32ProcessID)
else begin
If SearchInOther then
If pos(name,fFileN)<>0 then begin
Result:=OpenProcess(SYNCHRONIZE or PROCESS_TERMINATE, False,fData.th32ProcessID);
FileName:=GetProcessFilePath(name,fData.th 32ProcessID,true);
if FileName='' then
FileName:=fData.szExeFile;
end;
end;
end;

begin
fData.dwSize := SizeOf(fData);
fHandler := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
result:=0;
FileName:='';
try
if Process32First(fHandler, fData) then
begin
result:=SearchProcess;
If result<>0 then exit;

while Process32Next(fHandler, fData) do
begin
result:=SearchProcess;
If result<>0 then exit;
end;
end;
finally
CloseHandle(fHandler);
end;

end;

Function GetProcessFilePath(name:string;ProcessID&# 58;DWORD;findexe:boolean):string;
var
fData: TModuleEntry32;
fHandler: THandle;
fFileN:string;
tmpResult:string;

function GetFileName:string ;
begin
result:='';
If pos(name,fFileN)<>0 then begin
if findexe then begin
if pos('.exe',fFileN)<>0 then
result:=fData.szExePath;
end else
result:=fData.szExePath;
tmpResult:=fData.szExePath;
end;
end;

begin
fData.dwSize := SizeOf(fData);
fHandler := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, ProcessID);
tmpResult:='';
result:='';
fFileN:='';
name:=LowerCase(name);
try
if Module32First(fHandler, fData) then
begin
fFileN:=extractFileName(LowerCase(fDat a.szExePath));
result:=GetFileName;
if result<>'' then
exit;
while Module32Next(fHandler, fData) do
begin
fFileN:=extractFileName(LowerCase(fDat a.szExePath));
result:=GetFileName;
if result<>'' then
exit;
end;
end;
if (findexe) and (result='') then
result:=tmpResult;
finally
CloseHandle(fHandler);
end;
end;
منبع:
http://www.salarsoft.somee.com/questions/q_findprc.htm

[Keramatifar]

unit lDrives;
interface
uses Forms, Messages, Classes, WinProcs, WinTypes, SysUtils,
Dialogs, Controls;

const
MsgAskDefault = 'Please insert a disk on drive %s:';
MsgWProtected = 'Error: The disk %s is write-protected.';

type
TDriveType = (dtAll,dtFixed,dtRemovable,dtRemote{$IFDEF WIN32},dtCDRom,dtRamDisk{$ENDIF});

function ComposeFileName (Dir,Name:string):string;
function HasDiskSpace({$IFDEF WIN32}Drive: string{$ELSE}Drive: char{$ENDIF}; MinRequired: LongInt): boolean;
function GetDirectorySize(const Path: string): LongInt;
function GetFileSizeByName(const Filename: string): longInt;
function IsDiskRemovable(Drive: char): boolean;
function IsDiskInDrive(Drive: char): boolean;
function IsDiskWriteProtected(Drive: char): boolean;
function AskForDisk(Drive: char; Msg: string; CheckWriteProtected: boolean): boolean;
procedure GetAvailableDrives(DriveType: TDriveType; Items: TStrings);

implementation function ComposeFileName (Dir,Name:string):string;
var
Separator: string[1];
begin
if (length(Dir) > 0) and (Dir[length(Dir)]='\') then
delete(Dir, length(Dir), 1);
if (length(Name) > 0) and (Name[1]='\') then
delete(Name, 1, 1);
if Name='' then Separator:='' else Separator:='\';
result:=format('%s%s%s',[Dir,Separator,Name]);
end;

function HasDiskSpace(Drive: {$IFDEF WIN32}string{$ELSE}char{$ENDIF}; MinRequired: LongInt): boolean;
begin
if Drive='' then Drive:='C';
{$IFDEF WIN32}
result:=((GetDriveType(PChar(Drive))<>0) and
(SysUtils.DiskFree(Ord(UpCase(Drive[1]))-$40)=-1) or
(SysUtils.DiskFree(Ord(UpCase(Drive[1]))-$40)>=MinRequired));
{$ELSE}
result:=((GetDriveType(Ord(UpCase(Drive))-$40)<>0) and
(DiskFree(Ord(UpCase(Drive))-$40)=-1) or
(DiskFree(Ord(UpCase(Drive))-$40)>=MinRequired));
{$ENDIF}
end;

function GetDirectorySize(const Path: string): LongInt;
var
S: TSearchRec;
TotalSize: LongInt;
begin
TotalSize:=0;
if FindFirst(ComposeFileName(Path,'*.*'), faAnyFile, S)=0 then
repeat
Inc(TotalSize, S.Size);
until FindNext(S)<>0;
result:=TotalSize;
end;

function GetFileSizeByName(const Filename: string): longInt;
var
F: File;
begin
AssignFile(F, Filename);
Reset(F,1);
result:=FileSize(F);
CloseFile(F);
end;

function IsDiskRemovable(Drive: char): boolean;
begin
{$IFDEF WIN32}
result:=GetDriveType(PChar(Drive+':\'))=DRIVE_REMO VABLE;
{$ELSE}
result:=GetDriveType(ord(UpCase(Drive))-65)=DRIVE_REMOVABLE;
{$ENDIF}
end;

function IsDiskInDrive(Drive: char): Boolean;
var
ErrorMode: word;
begin
Drive:=Upcase(Drive);
if not (Drive in ['A'..'Z']) then
begin
Result:=False;
Exit;
end;
ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try
if DiskSize(Ord(Drive) - 64) = -1 then
Result := False
else
Result := True;
finally
SetErrorMode(ErrorMode);
end;
end;

function IsDiskWriteProtected(Drive: char): Boolean;
var
F: File;
ErrorMode: Word;
begin
ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
AssignFile(F,Drive+':\_$.$ );
try
try
Rewrite(F);
CloseFile(F);
Erase(F);
Result:=False;
except
Result:=True;
end;
finally
SetErrorMode(ErrorMode);
end;
end;

{$IFDEF WIN32}
procedure GetAvailableDrives(DriveType: TDriveType; Items: TStrings);
var
Drive: Integer;
DriveLetter: string;
begin
Items.Clear;
for Drive := 0 to 25 do
begin
DriveLetter := Chr(Drive + ord('A'))+':\';
case DriveType of
dtAll : if GetDriveType(PChar(DriveLetter)) in [DRIVE_REMOVABLE,DRIVE_FIXED,DRIVE_REMOTE,
DRIVE_CDROM,DRIVE_RAMDISK] then
Items.Add(DriveLetter);
dtRemovable: if GetDriveType(PChar(DriveLetter))=DRIVE_REMOVABLE then
Items.Add(DriveLetter);
dtFixed : if GetDriveType(PChar(DriveLetter))=DRIVE_FIXED then
Items.Add(DriveLetter);
dtRemote : if GetDriveType(PChar(DriveLetter))=DRIVE_REMOTE then
Items.Add(DriveLetter);
dtCDRom : if GetDriveType(PChar(DriveLetter))=DRIVE_CDROM then
Items.Add(DriveLetter);
dtRamDisk : if GetDriveType(PChar(DriveLetter))=DRIVE_RAMDISK then
Items.Add(DriveLetter);
end;
end;
end;
{$ELSE}
procedure GetAvailableDrives(DriveType: TDriveType; Items: TStrings);
var
Drive: Integer;
DriveLetter: char;
begin
Items.Clear;
for Drive := 0 to 25 do
begin
DriveLetter := Chr(Drive + ord('A'));
case DriveType of
dtAll : if GetDriveType(Drive) in [DRIVE_REMOVABLE,DRIVE_FIXED,DRIVE_REMOTE] then
Items.Add(DriveLetter+':\');
dtRemovable: if GetDriveType(Drive)=DRIVE_REMOVABLE then
Items.Add(DriveLetter+':\');
dtFixed : if GetDriveType(Drive)=DRIVE_FIXED then
Items.Add(DriveLetter+':\');
dtRemote : if GetDriveType(Drive)=DRIVE_REMOTE then
Items.Add(DriveLetter+':\');
end;
end;
end;
{$ENDIF}

function AskForDisk(Drive: char; Msg: string; CheckWriteProtected: boolean): boolean;
var
Ready : boolean;
begin
Ready:=false; Result:=false;
if Msg='' then Msg:=Format(MsgAskDefault,[Drive]);
while not(Ready) do
try
if IsDiskRemovable(Drive) then
case MessageDlg(Msg, mtConfirmation, [mbOk,mbCancel],0) of
mrOk : ready:=IsDiskInDrive(Drive);
mrCancel: exit;
end
else
Ready:=true;
except
result:=false;
exit;
end;
ready:=false;
while not(Ready) do
try
if CheckWriteProtected and IsDiskWriteProtected(Drive) then
begin
ready:=false;
if MessageDlg(Format(MsgWProtected,[Upcase(Drive)+':']),mtError,[mbRetry,mbCancel],0)=mrCancel then
exit;
end
else
ready:=true;
except
result:=false;
exit;
end;
result:=Ready;
end;

end.

[Keramatifar]

Procedure GetMDB97PassWord;

Const
XorArr : Array[0..12] of Byte =
($86,$FB,$EC,$37,$5D,$44,$9C,$FA,$C6,$5E,$28,$E6,$ 13);

Var
I : Integer;
S1 : String;
FI : File of Byte;
By : Byte;
Access97 : Boolean;
FileError : Boolean;

Begin
// Init
FileError := False;
Access97 := True;

// Open *.mbd file
AssignFile(FI,Filename);
Reset(FI);

// Read file
I := 0;
Repeat
If not Eof(FI) then
Begin
Read(FI,By);
Inc(I);
End;
Until (I = $42) or Eof(FI);
If Eof(FI) then
FileError := True;

// Read password string
S1 := '';
For I := 0 to 12 do
If not Eof(FI) then
Begin
Read(f,By);
S1 := S1 + Chr(By);
End;

If Eof(FI) then
FileError := True;

//Close file
CloseFile(FI);

// Is nul string?
If S1 = #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 then
Access97 := False;

// Decode string
For I := 0 to 12 do
S1[I + 1] := Chr(Ord(S[I + 1]) xor XORArr[I]);

// Find end of string
I := Pos(#0,S1);
If I = 1 then
S1 := '';
If I > 1 then
S1 := Copy(S1,1,I);

If Access97 then
Begin
If Length(S1) > 0 then
ShowMessage := ('The password is: "' + S1 + '".')
else
ShowMessage ('The file is NOT password protected.');
End
else
ShowMessage('The file is not an Access 97 file.');

If FileError then
ShowMessage('File error');

End;

[Keramatifar]

یکی از DLL های ویندوز به نام Winmm.dll دارای فانکشنی به نام waveOutGetNumDevs است که با استفاده از آن می توانید چک کنید کارت صدا در سیستم نصب شده است یا نه ...
ابتدا باید به این صورت تابع را تعریف کنید :


function IsSoundcardInstalled: longint; stdcall;
external 'winmm.dll'
name 'waveOutGetNumDevs';


و بدین صورت از آن استفاده کنید:



if IsSoundcardInstalled > 0 then
ShowMessage('Soundcard is there...');

[Keramatifar]

procedure GetVolume(var volL, volR: Word);
var
hWO: HWAVEOUT;
waveF: TWAVEFORMATEX;
vol: DWORD;
begin
volL:= 0;
volR:= 0;
// init TWAVEFORMATEX
FillChar(waveF, SizeOf(waveF), 0);
// open WaveMapper = std output of playsound
waveOutOpen(@hWO, WAVE_MAPPER, @waveF, 0, 0, 0);
// get volume
waveOutGetVolume(hWO, @vol);
volL:= vol and $FFFF;
volR:= vol shr 16;
waveOutClose(hWO);
end;


procedure SetVolume(const volL, volR: Word);
var
hWO: HWAVEOUT;
waveF: TWAVEFORMATEX;
vol: DWORD;
begin
// init TWAVEFORMATEX
FillChar(waveF, SizeOf(waveF), 0);
// open WaveMapper = std output of playsound
waveOutOpen(@hWO, WAVE_MAPPER, @waveF, 0, 0, 0);
vol:= volL + volR shl 16;
// set volume
waveOutSetVolume(hWO, vol);
waveOutClose(hWO);
end;

[Keramatifar]

ابتدا باید فانکشن را به این صورت تعریف کنید:



procedure SetCapsLockKey( vcode: Integer; down: Boolean );
begin
if Odd(GetAsyncKeyState( vcode )) <> down then
begin
keybd_event( vcode, MapVirtualkey( vcode, 0 ),
KEYEVENTF_EXTENDEDKEY, 0);
keybd_event( vcode, MapVirtualkey( vcode, 0 ),
KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0);
end;
end;



سپس به این صورت از آن استفاده کنید:


SetCapsLockKey( VK_CAPITAL, True );

توجه:
فانکشن های 'keybd_event', 'MapVirtualkey' , 'GetAsyncKeyState از فانشکن های API ویندوز هستند ...

[Keramatifar]

به سادگی با استفاده از این کد:


type
TyourForm = class(TForm)
private
{ Private declarations }
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
end;

procedure TyourForm.WMNCHitTest(var Message: TWMNCHitTest);
begin
inherited;

with Message do
if Result = HTCAPTION then
Result := HTNOWHERE;
end;

[Keramatifar]

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


Procedure EmptyRecycleBin ;
Const
SHERB_NOCONFIRMATION = $00000001 ;
SHERB_NOPROGRESSUI = $00000002 ;
SHERB_NOSOUND = $00000004 ;
Type
TSHEmptyRecycleBin = function (Wnd : HWND;
pszRootPath : PChar;
dwFlags : DWORD
) : HRESULT; stdcall ;
Var
SHEmptyRecycleBin : TSHEmptyRecycleBin;
LibHandle : THandle;
Begin { EmptyRecycleBin }
LibHandle := LoadLibrary(PChar('Shell32.dll')) ;
if LibHandle <> 0 then
@SHEmptyRecycleBin := GetProcAddress(LibHandle, 'SHEmptyRecycleBinA')
else
begin
MessageDlg('Failed to load Shell32.dll.', mtError, [mbOK], 0);
Exit;
end;


if @SHEmptyRecycleBin <> nil then
SHEmptyRecycleBin(Application.Handle,
nil,
SHERB_NOCONFIRMATION or SHERB_NOPROGRESSUI or SHERB_NOSOUND);
FreeLibrary(LibHandle);
@SHEmptyRecycleBin := nil ;
end;



نکته مهم:

البته سعی کنید این کار را قبل از ساعت 9 شب انجام دهید

[Keramatifar]

با استفاده از این کد می توانید یک درایو را در win32 فرمت کنید:


const SHFMT_DRV_A = 0;
const SHFMT_DRV_B = 1;
const SHFMT_ID_DEFAULT = $FFFF;
const SHFMT_OPT_QUICKFORMAT = 0;
const SHFMT_OPT_FULLFORMAT = 1;
const SHFMT_OPT_SYSONLY = 2;
const SHFMT_ERROR = -1;
const SHFMT_CANCEL = -2;
const SHFMT_NOFORMAT = -3;
function SHFormatDrive(hWnd : HWND;
Drive : Word;
fmtID : Word;
Options : Word) : Longint
stdcall; external 'Shell32.dll' name 'SHFormatDrive';
procedure TForm1.Button1Click(Sender: TObject);
var
FmtRes : longint;
begin
try
FmtRes:= ShFormatDrive(Handle,
SHFMT_DRV_A,
SHFMT_ID_DEFAULT,
SHFMT_OPT_QUICKFORMAT);
case FmtRes of
SHFMT_ERROR : ShowMessage('Error formatting the drive');
SHFMT_CANCEL :
ShowMessage('User canceled formatting the drive');
SHFMT_NOFORMAT : ShowMessage('No Format')
else
ShowMessage('Disk has been formatted');
end;
except
end;
end;

[mamizadeh]

preocedure wallpaper;
begin
systemparametersinfo(spi_setdeskwallpaper,0,pchar( 'f:paniz.bmp'),0);
end;

با تشکر از دوست محترمی که این قسمت را ایجاد کردند .
امید وارم که ادامه داشته باشد.

[mzjahromi]

این یه کد برای نوشتن یک عدد به حروفFunction TMB.Get1nd(i:integer):String;
Begin
case i of
0: Get1nd:=' &Otilde;&Yacute;&Ntilde; '; {zero}
1: Get1nd:=' &iacute;&szlig;&thorn; '; {one}
2: Get1nd:=' &Iuml;&aelig; '; {two}
3: Get1nd:=' &Oacute;&aring; '; {three}
4: Get1nd:=' &aring;&Ccedil;&Ntilde; '; {four}
5: Get1nd:=' &auml;&Igrave; '; {five}
6: Get1nd:=' &Ocirc;&Ocirc; '; {}
7: Get1nd:=' &aring;&Yacute;&Ecirc; '; {}
8: Get1nd:=' &aring;&Ocirc;&Ecirc; '; {}
9: Get1nd:=' &auml;&aring; '; {}
10: Get1nd:=' &Iuml;&aring; '; {}
11: Get1nd:=' &iacute;&Ccedil;&Ograve;&Iuml;&aring;&thorn; '; {}
12: Get1nd:=' &Iuml;&aelig;&Ccedil;&Ograve;&Iuml;&aring; '; {}
13: Get1nd:=' &Oacute;&iacute;&Ograve;&Iuml;&aring; '; {}
14: Get1nd:=' &aring;&Ccedil;&Ntilde;&Iuml;&aring; '; {}
15: Get1nd:=' &Ccedil;&auml;&Ograve;&Iuml;&aring; '; {}
16: Get1nd:=' &Ocirc;&Ccedil;&auml;&Ograve;&Iuml;&aring; '; {}
17: Get1nd:=' &aring;&Yacute;&Iuml;&aring; '; {}
18: Get1nd:=' &aring;&Igrave;&Iuml;&aring; '; {}
19: Get1nd:=' &auml;&aelig;&Ograve;&Iuml;&aring; '; {}
End;
End;
Function TMB.Get2nd(i:Integer):String;
Begin
case i of
2: Get2nd:=' &Egrave;&iacute;&Oacute;&Ecirc; '; {}
3: Get2nd:=' &Oacute;&iacute; '; {}
4: Get2nd:=' &aring;&aacute; '; {}
5: Get2nd:=' &auml;&Igrave;&Ccedil;&aring; '; {}
6: Get2nd:=' &Ocirc;&Otilde;&Ecirc; '; {}
7: Get2nd:=' &aring;&Yacute;&Ecirc;&Ccedil;&Iuml; '; {}
8: Get2nd:=' &aring;&Ocirc;&Ecirc;&Ccedil;&Iuml; '; {}
9: Get2nd:=' &auml;&aelig;&Iuml; '; {}
End;
End;
Function TMB.Get3nd(i:Integer):String;
Begin
case i of
1: Get3nd:=' &iacute;&szlig;&Otilde;&Iuml;&thorn; '; {}
2: Get3nd:=' &Iuml;&aelig;&iacute;&Oacute;&Ecirc; '; {}
3: Get3nd:=' &Oacute;&iacute;&Otilde;&Iuml; '; {}
4: Get3nd:=' &aring;&Ccedil;&Ntilde;&Otilde;&Iuml; '; {}
5: Get3nd:=' &Ccedil;&auml;&Otilde;&Iuml; '; {}
6: Get3nd:=' &Ocirc;&Ocirc;&Otilde;&Iuml; '; {}
7: Get3nd:=' &aring;&Yacute;&Ecirc;&Otilde;&Iuml; '; {}
8: Get3nd:=' &aring;&Ocirc;&Ecirc;&Otilde;&Iuml; '; {}
9: Get3nd:=' &auml;&aring;&Otilde;&Iuml; '; {}
End;
End;
Function TMB.GetTree(i:Integer):String;
var
a:String;
Begin
a:='';
if (i mod 100)>=20 then
Begin
if (i mod 10)>0 then
a:=Get1nd(i Mod 10)+a;
if (i mod 100 Div 10)>0 then
if length(a)>0 then
a:=Get2nd(i mod 100 Div 10)+'&aelig;'+a
Else
a:=Get2nd(i mod 100 Div 10)+a;
End
Else if (i mod 100) >0 then
a:=Get1nd(i Mod 100)+a;
if (i div 100)>0 then
if length(a)>0 then
a:=Get3nd(i Div 100)+'&aelig;'+a
Else
a:=Get3nd(i Div 100)+a;
if i=0 then
a:=Get1nd(0);
GetTree:=a;

End;
Function TMB.GetNum(Num:LongInt):String;
var
a:String;
i,mod1:Integer;
Begin
{ GetNum:=GetTree(Num);}
a:='';
i:=0;
repeat
mod1:=num mod 1000;
num:=num div 1000;
if (mod1>0) and (Length(a)>0) then
a:=' &aelig; '+a;
if (i=0)And(mod1>0) then
a:=GetTree(Mod1)+a
Else if (i=1) and (mod1>0) then
a:=GetTree(Mod1)+ '&aring;&Ograve;&Ccedil;&Ntilde;'+a {Towsand}
Else if (i=2) and (mod1>0) then
a:=GetTree(Mod1)+ '&atilde;&iacute;&aacute;&iacute;&aelig;&auml;'+ a {Milion}
Else if (i=3) and (mod1>0) then
a:=GetTree(Mod1)+ '&atilde;&iacute;&aacute;&iacute;&Ccedil;&Ntilde;& Iuml;'+a; {Miliard}
i:=i+1;
Until Num=0;
GetNum:=a+' '+Vahed;
End;

[ali_abbasi22145]

تغییر Resolution مونیتور

باید یک پروسیجر به شکل زیر بنویسیم:


procedure SetResolution(ResX, ResY: DWord);
var
lDeviceMode : TDeviceMode;
begin
EnumDisplaySettings(nil, 0, lDeviceMode);
lDeviceMode.dmFields:=DM_PELSWIDTH or DM_PELSHEIGHT;
lDeviceMode.dmPelsWidth :=ResX;
lDeviceMode.dmPelsHeight:=ResY;
ChangeDisplaySettings(lDeviceMode, 0);
end;

نکته بسیار مهم:

اگر اعداد غیر استاندارد برای Resolutoin مونیتور وارد کنید احتمال آسیب رسیدن به مونیتور وجود دارد، از رزولوشن های استاندارد مثل 320*240 ، 640*480 ، 1024*768 و ... استفاده کنید

سلام
1-با اخطار دوستم کمی ترسیدم!!! 1024 را مثلا کجا و 768 را کجا وارد کنیم.
2- می شود اول چک کند که 1024*768 است اگر نباشد به این حالت مانیتور را ببرد.

[Ehsansh]

procedure TForm1.Button1Click(Sender: TObject);
var DCWindow: HDC;
bmp: TBitmap;
begin
bmp := TBitmap.Create;
bmp.Height := Form1.Height;
bmp.Width := Form1.Width;
DCWindow := GetWindowDC(Form1.Handle);
BitBlt(bmp.Canvas.Handle, 0, 0, Form1.Width, Form1.Height,
DCWindow, 0, 0, SRCCOPY);
bmp.SaveToFile('C:\ScreenShot.bmp');
ReleaseDC(DCWindow, DCWindow);
bmp.Free;
end;

اندکی ویرایش
mzjahromi

[Mahmood_M]

اینم کد Drop & Dawn کردن آیتم های لیست باکس

var // form level
StartingPoint : TPoint;

implementation

...

procedure TForm1.FormCreate(Sender: TObject) ;
begin
ListBox1.DragMode := dmAutomatic;
end;

procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer) ;
var
DropPosition, StartPosition: Integer;
DropPoint: TPoint;
begin
DropPoint.X := X;
DropPoint.Y := Y;
with Source as TListBox do
begin
StartPosition := ItemAtPos(StartingPoint,True) ;
DropPosition := ItemAtPos(DropPoint,True) ;

Items.Move(StartPosition, DropPosition) ;
end;
end;

procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean) ;
begin
Accept := Source = ListBox1;
end;

procedure TForm1.ListBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer) ;
begin
StartingPoint.X := X;
StartingPoint.Y := Y;
end;

[Mahmood_M]

اینم کدش

var
bmp: TBitmap;
begin
bmp:=TBitmap.Create;
try
bmp.Width := Image.Picture.Graphic.Width;
bmp.Height := Image.Picture.Graphic.Height;
bmp.Canvas.Draw(0, 0, Image.Picture.Graphic) ;
BitBtn.Glyph:=bmp;
finally
bmp.Free;
end;
end;

[Mahmood_M]

یک Open Dialog و یک دکمه بر روی فرم بزارید ...

با کد زیر ، بعد از باز شدن فایل به وسیله Open Dialog و زدن دکمه پنجره خصوصیات فایل نشون داده می شه :

uses
shellapi;

procedure PropertiesDialog(FileName: string);
var
sei: TShellExecuteInfo;
begin
FillChar(sei, SizeOf(sei), 0);
sei.cbSize := SizeOf(sei);
sei.lpFile := PChar(FileName);
sei.lpVerb := 'properties';
sei.fMask := SEE_MASK_INVOKEIDLIST;
ShellExecuteEx(@sei);
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
if Opendialog1.Execute then
PropertiesDialog(Opendialog1.FileName);
end;

[mrkh1759]

تابع زیر مشخص می کنه که سیستم متصل به انترنت هست یا نه

Compilers Delphi
Category Internet
Uses
Windows,
WinInet;

Function ConnectedToInternet:Boolean;
Var Flags : DWORD;
Begin
Flags :=INTERNET_CONNECTION_MODEM or INTERNET_CONNECTION_LAN or INTERNET_CONNECTION_PROXY;
Result:=InternetGetConnectedState(@Flags, 0);
End;

[mrkh1759]

بدت آوردن نام کاربر

Uses
Windows,
SysUtils;

function GetUserName : String;
var
Name : PChar;
Size : DWORD;
begin
Size := SizeOf(ShortString);
GetMem(Name, Size);
try
GetUserName(Name, Size);
Result := Trim(StrPas(Name));
finally
FreeMem(Name, Size);
end;
end;البته دوستان منو ببخشند که دخالت کردیم
گفتم شاید چند تا ای پی آی که فکر می کنم خوبه بدرد دوستان بخوره

[mrkh1759]

Uses
Windows,
Graphics,
ShellApi;

Procedure GetIcon(Filename,IconFilename:String;SmallIcon:Boo lean);
Var
HIcon32 ,
HIcon16 : HIcon;
Icon : tIcon;
Begin
ExtractIconEx(Pchar(Filename),0,HIcon32,HIcon16,1) ;

If (HIcon16<>0) and SmallIcon then
Begin
Icon:=tIcon.Create;
Icon.handle:=HIcon16;
Icon.SaveToFile(IconFilename);
Icon.Free;
end else
If (HIcon32<>0) and not SmallIcon then
Begin
Icon:=tIcon.Create;
Icon.handle:=HIcon32;
Icon.SaveToFile(IconFilename);
Icon.Free;
end;
End;

[Ehsansh]

این تابع برنامه مورد نظر را اجر میکند و تا زمان خاتمه آن منتظر میماند.


Function ExecuteAndWait(sExecutableFile : String) : Boolean;
var
siInfo : TStartUpInfo;
piInfo : TProcessInformation;
begin
FillChar(siInfo, SizeOf(siInfo), #0);

with siInfo do begin
cb := SizeOf(siInfo);
dwFlags := STARTF_USESHOWWINDOW;
wShowWindow := SW_SHOWNORMAL;
end;
Result := CreateProcess(NIL, pChar(sExecutableFile), NIL, NIL, FALSE, CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, NIL, pchar(ExtractFilePath(sExecutableFile)),siInfo, piInfo);
if Result then
WaitForSingleObject(piInfo.hprocess,INFINITE);
end;

[mzjahromi]

روشن و خاموش کردن Numlock


function SetNumLock(Active: Boolean): Boolean;
begin

// Check to see if the desired state is set
if (Active <> ((GetKeyState(VK_NUMLOCK) and 1) = 1)) then
begin
// Turn on / off
keybd_event(VK_NUMLOCK, 45, KEYEVENTF_EXTENDEDKEY, 0);
keybd_event(VK_NUMLOCK, 45, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP , 0);
end;

end;

[mahsa119]

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState);
var
test1: Real;
RowNo: Integer;
begin
with (Sender as TDBGrid) do
begin
if (gdSelected in State) then
begin
// Farbe f&#252;r die Zelle mit dem Focus
// color of the focused row
Canvas.Brush.Color := clblue;
end
else
begin
// Zeile erfahren
// get the actual row number
rowno := Query1.RecNo;
// gerade und ungerade Zeilen ermitteln
// odd or even ?
test1 := (RowNo / 2) - trunc(RowNo / 2);
// Zeile gerade...
// If it's an even one...
if test1 = 0 then
begin
farbe := clWhite
end
// ...Zeile ungerade
// ...else it's an odd one
else
begin
farbe := clYellow;
end;
Canvas.Brush.Color := farbe;
// Font-Farbe immer schwarz
// font color always black
Canvas.Font.Color := clBlack;
end;
Canvas.FillRect(Rect);
// Denn Text in der Zelle ausgeben
// manualy output the text
Canvas.TextOut(Rect.Left + 2, Rect.Top + 1, Column.Field.AsString);
end
end;

[mahsa119]

چگونه سایز Col را در یک DBGrid به صورت اتوماتیک قرار دهیم



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

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

[mahsa119]

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

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

[mahsa119]

procedure TForm1.Button1Click(Sender: TObject);
begin
ADOCommand1.CommandText := 'Use DataBaseName';
ADOCommand1.Execute;
ADOCommand1.CommandText := 'Exec SP_AddUser ' + QuotedStr('Username');
ADOCommand1.Execute;
end;



{* For Any Infromation Mail Me *

Mail : Mostafa@Touska.Co.ir0


...Add a user into a database in Sql Server 2000?

[mzjahromi]

uses MMSystem;



type

TVolumeRec = record

case Integer of

0: (LongVolume: Longint) ;

1: (LeftVolume, RightVolume : Word) ;

end;



const DeviceIndex=5

{0:Wave

1:MIDI

2:CDAudio

3:Line-In

4:Microphone

5:Master

6:PC-loudspeaker}



procedure SetVolume(aVolume:Byte) ;

var Vol: TVolumeRec;

begin

Vol.LeftVolume := aVolume shl 8;

Vol.RightVolume:= Vol.LeftVolume;

auxSetVolume(UINT(DeviceIndex), Vol.LongVolume) ;

end;



function GetVolume:Cardinal;

var Vol: TVolumeRec;

begin

AuxGetVolume(UINT(DeviceIndex),@Vol.LongVolume) ;

Result:=(Vol.LeftVolume + Vol.RightVolume) shr 9;

end;





لینک اصلی

[mzjahromi]

کامپوننت TImage برای نمایش تصاویر گرافیکی مورد استفاده قرار میگیرد(Ico,BMP,WMF,GIF,JPEG و مانند آن)خاصیت Picture مشخص کننده تصویری است که باید نمایش داده شود به منظور مقدار دادن به این خاصیت راههای زیادی وجود دارد: استفاده از خاصیت LoadFromFile که می توان به منظور خواندن یک فایل گرافیکی از هارد از آن استفاده کرد یا تابع Assign که می توان توسط آن تصاویر موجود در حافظه موقت(ClipBoard)
در بیشتر حالات شما تصویر خود را در زمان طراحی نرم افزار مقدار دهی میکنیدو این کار با مقدار دهی خاصیت Picture از Objectinspector امکان پذیر است
در صورتیکه میخواهید تصویر را در زمان اجرا حذف کنید مقدار خاصیت Picture را برابر با NIL قرار دهید.
و در صورتیکه بخواهید خالی بودن تصور را کنترل کنید از کد زیر استفاده کنید




if Image1.Picture.Graphic.Empty then
begin
...
end;

لینک اصلی

[mzjahromi]

بدین منظور میتوانید از کنترل TScreen و رویداد onActiveControlChange استفاده کنید




const
focusColor = clSkyBlue;

var
lastFocused : TWinControl;
originalColor : TColor;



توجه داشته باشید که کامپوننتی تحت عنوان TScreen برای قرار دادن روی فرم وجود ندارد و شما باید بصورت دستی رویدادها را تنظیم کنید




procedure TMainForm.FormCreate(Sender: TObject) ;
begin
Screen.OnActiveControlChange := ScreenActiveControlChange;
end;

procedure TMainForm.FormDestroy(Sender: TObject) ;
begin
Screen.OnActiveControlChange := nil;
end;



و پیاده سازی رویداد ذکر شده به صورت زیر است




procedure TMainForm.ScreenActiveControlChange(Sender: TObject) ;
var
doEnter, doExit : boolean;
previousActiveControl : TWinControl;
begin
if Screen.ActiveControl = nil then
begin
lastFocused := nil;
Exit;
end;

doEnter := true;
doExit := true;

//CheckBox
if Screen.ActiveControl is TButtonControl then doEnter := false;

previousActiveControl := lastFocused;

if previousActiveControl <> nil then
begin
//CheckBox
if previousActiveControl is TButtonControl then doExit := false;
end;

lastFocused := Screen.ActiveControl;

if doExit then ExitColor(previousActiveControl) ;
if doEnter then EnterColor(lastFocused) ;
end;

procedure TMainForm.EnterColor(Sender: TWinControl);
begin
if Sender <> nil then
begin
if IsPublishedProp(Sender,'Color') then
begin
originalColor := GetOrdProp(Sender,'Color');
SetOrdProp(Sender,'Color', focusColor);
end;
end;
end;

procedure TMainForm.ExitColor(Sender: TWinControl);
begin
if Sender <> nil then
begin
if IsPublishedProp(Sender,'Color') then
begin
SetOrdProp(Sender,'Color',originalColor);
end;
end;
end;

[adelmobasheri]

جناب این TMB که استفاده کردی چیه؟

[mohebbi_en]

salam
bebakhshid
khat zir da barnameh CPUID chekar mikonad.

if s1 &lt;> ' ' then


ba tashakor

[vesal]

سلام.
با این کد می تونید در کنترل DBGrid برای مقادیر منطقی به جای True یا False از CheckBox استفاده کنید

این کد یونیت :


unit Unit1;

interface

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

type
TForm1 = class(TForm)
DBGrid1: TDBGrid;
Table1: TTable;
DataSource1: TDataSource;
procedure DBGrid1CellClick(Column: TColumn);
procedure DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
procedure DBGrid1ColEnter(Sender: TObject);
procedure DBGrid1ColExit(Sender: TObject);
private

FOriginalOptions : TDBGridOptions; { Private declarations }
public
procedure SaveBoolean;
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.SaveBoolean;
begin
Self.DBGrid1.SelectedField.Dataset.Edit;
Self.DBGrid1.SelectedField.AsBoolean := not Self.DBGrid1.SelectedField.AsBoolean;
Self.DBGrid1.SelectedField.Dataset.Post;
end;

procedure TForm1.DBGrid1CellClick(Column: TColumn);
begin
if Self.DBGrid1.SelectedField.DataType = ftBoolean then
SaveBoolean();
end;

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
Const
CtrlState : array[Boolean] of Integer = (DFCS_BUTTONCHECK,
DFCS_BUTTONCHECK or DFCS_CHECKED);
var
CheckBoxRectangle : TRect;
begin
if Column.Field.DataType = ftBoolean then
begin
Self.DBGrid1.Canvas.FillRect(Rect);
CheckBoxRectangle.Left := Rect.Left + 2;
CheckBoxRectangle.Right := Rect.Right - 2;
CheckBoxRectangle.Top := Rect.Top + 2;
CheckBoxRectangle.Bottom := Rect.Bottom - 2;
DrawFrameControl(Self.DBGrid1.Canvas.Handle,
CheckBoxRectangle,
DFC_BUTTON,
CtrlState[Column.Field.AsBoolean]);
end;
end;
procedure TForm1.DBGrid1ColEnter(Sender: TObject);
begin
if Self.DBGrid1.SelectedField.DataType = ftBoolean then
begin
Self.FOriginalOptions := Self.DBGrid1.Options;
Self.DBGrid1.Options := Self.DBGrid1.Options - [dgEditing];
end;
end;

procedure TForm1.DBGrid1ColExit(Sender: TObject);
begin
if Self.DBGrid1.SelectedField.DataType = ftBoolean then
Self.DBGrid1.Options := Self.FOriginalOptions;
end;

end.

این هم مال فرم

object Form1: TForm1
Left = 192
Top = 114
Width = 953
Height = 778
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object DBGrid1: TDBGrid
Left = 0
Top = 0
Width = 945
Height = 744
Align = alClient
DataSource = DataSource1
TabOrder = 0
TitleFont.Charset = DEFAULT_CHARSET
TitleFont.Color = clWindowText
TitleFont.Height = -11
TitleFont.Name = 'MS Sans Serif'
TitleFont.Style = []
OnCellClick = DBGrid1CellClick
OnColEnter = DBGrid1ColEnter
OnColExit = DBGrid1ColExit
OnDrawColumnCell = DBGrid1DrawColumnCell
end
object Table1: TTable
Active = True
DatabaseName = 'DBDEMOS'
TableName = 'reservat.db'
Left = 128
Top = 88
end
object DataSource1: TDataSource
DataSet = Table1
Left = 176
Top = 80
end
end

[Touska]

procedure TForm1.Button1Click(Sender: TObject);
begin
ADOCommand1.CommandText := 'Use DataBaseName';
ADOCommand1.Execute;
ADOCommand1.CommandText := 'Exec SP_AddUser ' + QuotedStr('Username');
ADOCommand1.Execute;
end;



{* For Any Infromation Mail Me *

Mail : Mostafa@Touska.Co.ir


...Add a user into a database in Sql Server 2000?


خیلی جالبه- تازه دیدمش - قصد هدر دادن وقت دیگران را ندارم - شرمنده :قهقهه: این Email وجود نداره :لبخند:

[davoodmz]

لطفاً بیشتر توضیح بدهید که بدانیم . این user به چه شکل اضافه می شود آیا قبلاً دیتابیس باید در sql باشد. اگر برای کنترل یوزرها از یک جدول در sqlاستفاده می کنیم . اضافه کردن و حذف و دادن امکانات به یوزر مثل ثبت یک رکورد امکان دارد
با تشکر
داود








procedure TForm1.Button1Click(Sender: TObject);
begin
ADOCommand1.CommandText := 'Use DataBaseName';
ADOCommand1.Execute;
ADOCommand1.CommandText := 'Exec SP_AddUser ' + QuotedStr('Username');
ADOCommand1.Execute;
end;



{* For Any Infromation Mail Me *

Mail : Mostafa@Touska.Co.ir0


...Add a user into a database in Sql Server 2000?

[Touska]

این USer قبلا ساخته شده حالا به این دیتابیس اضافه میشه :)

[amir_22]

تبدیل عدد به حرف



punit Curr2Str;

interface
function Add2Harf(i:int64):string;

implementation

function Add2Harf(i:int64):string;
const v=' æ ';
var
ok:boolean;
{___________________________________}
function yekan(y:byte):string;
begin
case y of
0:result:='';
1:result:='íß';
2:result:='Ïæ';
3:result:='Óå';
4:result:='چåÇÑ';
5:result:='پäÌ';
6:result:='ÔÔ';
7:result:='åÝÊ';
8:result:='åÔÊ';
9:result:='äå';
enD;
if result=''then ok:=false else ok:=true;
end;
{___________________________________}
function dahgan(y:byte):string;
begin
case y of
0:result:='';
1:result:='Ïå';
2:result:='ÈíÓÊ';
3:result:='Óí';
4:result:='چåá';
5:result:='پäÌÇå';
6:result:='ÔÕÊ';
7:result:='åÝÊÇÏ';
8:result:='åÔÊÇÏ';
9:result:='äæÏ';
enD;
if result=''then ok:=false else ok:=true;
end;
{___________________________________}
function sadgan(y:byte):string;
begin
case y of
0:result:='';
1:result:='íßÕÏ';
2:result:='ÏæíÓÊ';
3:result:='ÓíÕÏ';
4:result:='چåÇÑÕÏ';
5:result:='پÇäÕÏ';
6:result:='ÔÔÕÏ';
7:result:='åÝÊÕÏ';
8:result:='åÔÊÕÏ';
9:result:='äåÕÏ';
enD;
if result=''then ok:=false else ok:=true;
end;
{___________________________________}
function dah(y:byte):string;
begin
case y of
0:result:='';
10:result:='Ïå';
11:result:='íÇÒÏå';
12:result:='ÏæÇÒÏå';
13:result:='ÓíÒÏå';
14:result:='چåÇÑÏå';
15:result:='پÇäÒÏå';
16:result:='ÔÇäÒÏå';
17:result:='åÝÏå';
18:result:='åÌÏå';
19:result:='äæÒÏå';
enD;
if result=''then ok:=false else ok:=true;
end;
{___________________________________}
function seragham(si:smallint):string;
begin
result:='';
result:=sadgan(si div 100);
if ok then result:=result+v;

if((si mod 100)div 10) <> 1 then begin
result:=result+dahgan((si mod 100)div 10);
if ok then result:=result+v;
result:=result+yekan(si mod 10);
if not ok then result:=copy(result,1,length(result)-3);
End
else begin
result:=result+dah(si mod 100);
end;
if result='' then ok:=false else ok:=true;
end;
{___________________________________}
const
tr=' ÊÑíáíæä';
mr=' ãíáíÇÑÏ';
ml=' ãíáíæä';
hz=' åÒÇÑ';
begin
ok:=false;

result:=seragham(i div 1000000000000);
if ok then result:=result+tr+v;
result:=result+seragham((i mod 1000000000000)div 1000000000);
if ok then result:=result+mr+v;
result:=result+seragham((i mod 1000000000)div 1000000);
if ok then result:=result+ml+v;
result:=result+seragham((i mod 1000000)div 1000);
if ok then result:=result+hz+v;
result:=result+seragham(i mod 1000);
if not ok then result:=copy(result,1,length(result)-3);

if i=0 then result:='ÕÝÑ';
end;



end.

[jamjid]

نشان دادن فرم بدون دکمه ای در تسکبار
procedure TForm1.FormCreate(Sender: TObject);
begin
SetWindowLong(Application.Handle,GWL_EXSTYLE,WS_EX _TOOLWINDOW);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action:=caNone;
Form1.Hide;
end;[QUOTE][/QUOTE

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

procedure TForm1.Button1Click(Sender: TObject);
var nday:Double;
tick:Longint;
btime:TDateTime;
s:string;
begin
tick:=GetTickCount;
nday:=tick/86400000;
btime:=Now-nday;
s:='"Windows started on" dddd,mmmm d,yyyy,'+'"at" hh:nn:ss AM/PM';
showmessage( FormatDateTime(s,btime)+#10#13+
'It been up for '+IntToStr(TRUNC(nday))+' Days,'+
FormatDateTime(' h "Houre," n "minutes," s "seconds"',nday));
end;

[partorad]

آیا کسی هست کمک کنه
میخواهم مشخصات سخت افزار کامپیوتری که به آن کانکت کرده ام (server )را بدست بیاورم مانند سریال سخت افزاری هارد ( نهVolumelable ) ، سریال CPU ، سریال فلش مموری

[Touska]

آیا کسی هست کمک کنه
میخواهم مشخصات سخت افزار کامپیوتری که به آن کانکت کرده ام (server )را بدست بیاورم مانند سریال سخت افزاری هارد ( نهVolumelable ) ، سریال CPU ، سریال فلش مموری

سئوال خود را به بخش مباحث برنامه نویسی منتفل نمایید.

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

یک نمونه از این برنامه رو من تهیه کردم که از Indy و Mitec System Information در پروژه سود بردم.

موفق باشید :)

[dkhatibi]

تشخیص اتصال به شبکه


procedure TForm1.Button1Click(Sender: TObject);
begin
if GetSystemMetrics(SM_NETWORK) AND $01 = $01 then
MessageDlg('Machine is attached to network',MtInformation,[mbok],0)
else
MessageDlg('Machine is not attached to network',mtInformation,[mbok],0);
end;

[dkhatibi]

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

[vesal]

procedure CreateShortcut(SourceFileName, Title: string; Location:
ShortcutType; SubDirectory : string);
var
MyObject : IUnknown;
MySLink : IShellLink;
MyPFile : IPersistFile;
Directory,
LinkName : string;
WFileName : WideString;
MyReg,
QuickLaunchReg : TRegIniFile;
begin
MyObject := CreateComObject(CLSID_ShellLink);
MySLink := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;

MySLink.SetPath(PChar(SourceFileName));

MyReg := TRegIniFile.Create('Software\MicroSoft\Windows\Cur rentVersion\Explorer');
try
LinkName := ChangeFileExt(SourceFileName, '.lnk');
LinkName := ExtractFileName(LinkName);
case Location of
_DESKTOP : Directory := MyReg.ReadString('Shell Folders', 'Desktop', '');
_STARTMENU : Directory := MyReg.ReadString('Shell Folders', 'Start Menu', '');
_SENDTO : Directory := MyReg.ReadString('Shell Folders', 'SendTo', '');
_QUICKLAUNCH:
begin
QuickLaunchReg := TRegIniFile.Create('Software\MicroSoft\Windows\Cur rentVersion\GrpConv');

try
Directory := QuickLaunchReg.ReadString('MapGroups', 'Quick Launch', '');
finally
QuickLaunchReg.Free;
end; {try..finally}
end; {case _QUICKLAUNCH}
end; {case}
if Directory <> '' then
begin
if SubDirectory <> '' then
WFileName := Directory + '\'+ SubDirectory +'\' + LinkName
else
WFileName := Directory + '\' + LinkName;
MyPFile.Save(PWChar(WFileName), False);
end; {Directory <> ''}
finally
MyReg.Free;
end; {try..finally}
end; {CreateShortcut}

[mehdi_mohamadi]

unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function EnumWinProc(Wnd : HWND) : Boolean; Export; StdCall;
var
WinText : Array[0..255] of Char;
begin
GetWindowText(Wnd, WinText, 255);
Result := True;
if (StrPas(WinText) <> '') and
IsWindowVisible(Wnd) and
(Wnd<>Application.Handle) and
(Wnd<>Form1.Handle)
then
CloseWindow(Wnd);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
EnumWindows(@EnumWinProc, LongInt(Self));
end;
end.

[mehdi_mohamadi]

unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure FechaDelSistema(Fecha: TDateTime);
var
FecSys: TSystemTime;
nA, nM, nD: Word;
begin
DecodeDate(Fecha, nA,nM,nD);
GetLocalTime(FecSys);
FecSys.wYear := nA;
FecSys.wMonth := nM;
FecSys.wDay := nD;
SetLocalTime(FecSys);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin

FechaDelSistema( StrToDate('2006/10/09') );
end;
end.

[Mah6447]

محاسبه و نمایش مجموع مقادیر فیلدهای DbGrid
برداشت از سایت
http://search.experts-exchange.com/

[babak_delphi]

تغییر Resolution مونیتور
باید یک پروسیجر به شکل زیر بنویسیم:


procedure SetResolution(ResX, ResY: DWord);
var
lDeviceMode : TDeviceMode;
begin
EnumDisplaySettings(nil, 0, lDeviceMode);
lDeviceMode.dmFields:=DM_PELSWIDTH or DM_PELSHEIGHT;
lDeviceMode.dmPelsWidth :=ResX;
lDeviceMode.dmPelsHeight:=ResY;
ChangeDisplaySettings(lDeviceMode, 0);
end;

نکته بسیار مهم:
اگر اعداد غیر استاندارد برای Resolutoin مونیتور وارد کنید احتمال آسیب رسیدن به مونیتور وجود دارد، از رزولوشن های استاندارد مثل 320*240 ، 640*480 ، 1024*768 و ... استفاده کنید

[delphi5]

shutdown and restart and logof windows



function WindowsExit(RebootParam: Longword): Boolean;

var
TTokenHd: THandle;
TTokenPvg: TTokenPrivileges;
cbtpPrevious: DWORD;
rTTokenPvg: TTokenPrivileges;
pcbtpPreviousRequired: DWORD;
tpResult: Boolean;
const
SE_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,
SE_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;



نحوه استفاده




//reboot windows
ExitWindowsEx(EWX_REBOOT, 0) ;

//shut down windows
ExitWindowsEx(EWX_SHUTDOWN, 0) ;

// log off and prompt for login
ExitWindowsEx(EWX_LOGOFF, 0) ;

[Keramatifar]

سلام
1-با اخطار دوستم کمی ترسیدم!!! 1024 را مثلا کجا و 768 را کجا وارد کنیم.
2- می شود اول چک کند که 1024*768 است اگر نباشد به این حالت مانیتور را ببرد.

برای اینکه رزولوشن فعلی مونیتور را بدست بیاری کافیه دو متغیر x,y از نوع int تعریف کنی و به این صورت عمل کنی:



x:= screen.width;
y:=screen.height

حالا رزولوشن صفحه رو توی دو متغیر داری (افقی داخل x و عمودی داخل y) موقعی که میخوای رزولوشن رو چک کنی که اگه مثلا 800 در 600 نبود عوضش کنه این کد رو بزن:



if (x<>800) and (y<>600)
then ....

در ضمن بعد از پایان کارت می تونی با استفاده از همین دو متغیر رزولوشن مونیتور را به حالت اصلی بر گردونی

[hr110]

تصویر توسعه‌دهندگان دلفی 7

کافی است به محض اجرا Delphi 7 دو کلید CTRL و SHIFT را پایین نگه دارید:

http://i2.tinypic.com/66eof1y.jpg

به نظر شما این تصویر با چه تکنیکی capture شده است؟

[Hamid_PaK]

به نظر شما این تصویر با چه تکنیکی capture شده است؟
کلید PrtScrn -> واژه Enterprise ...

یا حق ...

[شیلا .ک]

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

[Future_Coder]

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

---------------------------------------
Persians Are Rulerz!Persians Are Creator Of Algorithmic Method For Solving A Problem
And Now It's Honor To be A Coder

[پرواز]

کافی است به محض اجرا Delphi 7 دو کلید CTRL و SHIFT را پایین نگه دارید:

سلام.

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

موفق باشید

[hr110]

ریسورس لزوماً در فایل اجرایی نیست، میتوان این تصویر را در هر فایل دیگری قرار داد.
به دنبال فایل با پسوند JPG, GIF,BMP نباشید.

[hossein taghi zadeh]

با سلام


دوم اینکه این عکس به سورس برنامه اد شده باشه که از Borland بعیده که بیاد با بالا بردن حجم برنامه سرعتش رو کم کنه.

این عکس با نام SPLASHHIGH1 در بخش RCData ریسورس فایل اجرایی دلفی هست.
می‌تونید با برنامه‌هایی مثل EXEScope این عکس رو ببینید.

[msseng]

سلام
ممنون از نکات بسیار جالبی که مطرح میکنید.
یه سوال داشتم... نمدونم جاش اینجا هست یا نه ولی در هر صورت شما ببخشید:
منظور از lt& که بعضی جاها استفاده شده چیه؟
آیا یه عملگر هست؟ چون همیشه بعد از یک متغیر میاد...

[ali_abbasi22145]

محاسبه و نمایش مجموع مقادیر فیلدهای DbGrid
برداشت از سایت
http://search.experts-exchange.com/

سلام برنامه تان خطا می دهد!

[msseng]

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

[Vahid_moghaddam]

با این روش:



type
TShopItem = record
Name : string;
Price : currency;
end;


const
Days : array[0..6] of string =
(
'Sun', 'Mon', 'Tue', 'Wed',
'Thu', 'Fri', 'Sat'
) ;


CursorMode : array [B]of TCursor =
(
crHourGlass, crSQLWait
) ;


Items : array[1..3] of TShopItem =
(
(Name : 'Clock'; Price : 20.99),
(Name : 'Pencil'; Price : 15.75),
(Name : 'Board'; Price : 42.96)
) ;

[Vahid_moghaddam]

مرجع:
http://delphi.about.com

[Vahid_moghaddam]

procedure Shuffle(
var aArray;
aItemCount: Integer;
aItemSize: Integer) ;
var
Inx: Integer;
RandInx: Integer;
SwapItem: PByteArray;
A: TByteArray absolute aArray;
begin
if (aItemCount > 1) then
begin
GetMem(SwapItem, aItemSize) ;
try
for Inx := 0 to (aItemCount - 2) do
begin
RandInx := Random(aItemCount - Inx) ;
Move(A, SwapItem^, aItemSize) ;
Move(A[RandInx * aItemSize],
A, aItemSize) ;
Move(SwapItem^, A[RandInx * aItemSize],
aItemSize) ;
end;
finally
FreeMem(SwapItem, aItemSize) ;
end;
end;
end;


procedure TForm1.Button1Click(Sender: TObject) ;
var
a: array[1..54] of Integer;
i: Shortint;
begin
Randomize;
for i := Low(a) to High(a) do a[I] := i;
Shuffle(a, High(a), SizeOf(Integer)) ;
ListBox1.Clear;
for i := 1 to High(a) - 1 do
ListBox1.Items.Add(IntToStr(a[I])) ;
end;

[M0h$enRunTime]

آقای Wish مطالب خوبیه
فقط اگه بشه راجع به اون بحث کرد خیلی خوب می شد
منظورم درک عمقی کد های نوشته شده
اگه بشه بحث کرد اونوقت همه می تونن از API استفاده کنن و کد بنویسن

[Mah6447]

سلام برنامه تان خطا می دهد!

فایل ضمیمه همان پست اصلاح شد ...

[Keramatifar]

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

[Vahid_moghaddam]

procedure TForm1.Button1Click(Sender: TObject) ;

function FuncAvail(_dllname, _funcname: string;
var _p: pointer): boolean;
{return True if _funcname exists in _dllname}
var _lib: tHandle;
begin
Result := false;
if LoadLibrary(PChar(_dllname)) = 0 then exit;
_lib := GetModuleHandle(PChar(_dllname)) ;
if _lib <> 0 then begin
_p := GetProcAddress(_lib, PChar(_funcname)) ;
if _p <> NIL then Result := true;
end;
end;

{
Call SHELL32.DLL for Win < Win98
otherwise call URL.dll
}
{button code:}
var
InetIsOffline : function(dwFlags: DWORD):
BOOL; stdcall;
begin
if FuncAvail('URL.DLL', 'InetIsOffline',
@InetIsOffline) then
if InetIsOffLine(0) = true
then ShowMessage('Not connected')
else ShowMessage('Connected!') ;
end;

[Vahid_moghaddam]

uses ExtActns, ...

type
TfrMain = class(TForm)
...
private
procedure URL_OnDownloadProgress
(Sender: TDownLoadURL;
Progress, ProgressMax: Cardinal;
StatusCode: TURLDownloadStatus;
StatusText: String; var Cancel: Boolean) ;
...

implementation
...

procedure TfrMain.URL_OnDownloadProgress;
begin
ProgressBar1.Max:= ProgressMax;
ProgressBar1.Position:= Progress;
end;

function DoDownload;
begin
with TDownloadURL.Create(self) do
try
URL:='http://z.about.com/6/g/delphi/b/index.xml';
FileName := 'c:\ADPHealines.xml';
OnDownloadProgress := URL_OnDownloadProgress;

ExecuteTarget(nil) ;
finally
Free;
end;
end;

[Vahid_moghaddam]

function GetIEFavourites
(const favpath: string):TStrings;
var
searchrec:TSearchrec;
str:TStrings;
path,dir,filename:String;
Buffer: array[0..2047] of Char;
found:Integer;
begin
str:=TStringList.Create;
try
path:=FavPath+'\*.url';
dir:=ExtractFilepath(path) ;
found:=FindFirst(path,faAnyFile,searchrec) ;
while found=0 do begin
SetString(filename, Buffer,
GetPrivateProfileString('InternetShortcut',
PChar('URL'), NIL, Buffer, SizeOf(Buffer),
PChar(dir+searchrec.Name))) ;
str.Add(filename) ;
found:=FindNext(searchrec) ;
end;
found:=FindFirst(dir+'\*.*',faAnyFile,searchrec) ;
while found=0 do begin
if ((searchrec.Attr and faDirectory) > 0)
and (searchrec.Name[1]<>'.') then
str.AddStrings(GetIEFavourites
(dir+'\'+searchrec.name)) ;
found:=FindNext(searchrec) ;
end;
FindClose(searchrec) ;
finally
Result:=str;
end;
end;

procedure TForm1.Button1Click(Sender: TObject) ;
var pidl: PItemIDList;
FavPath: array[0..MAX_PATH] of char;
begin
SHGetSpecialFolderLocation(Handle, CSIDL_FAVORITES, pidl) ;
SHGetPathFromIDList(pidl, favpath) ;
ListBox1.Items:=GetIEFavourites(StrPas(FavPath)) ;
end;

[Vahid_moghaddam]

uses Registry;
...
function SetIEHomePage(PageName: string): Boolean;
begin
with TRegistry.Create do
try
RootKey := HKEY_CURRENT_USER;
OpenKey('Software\Microsoft\Internet Explorer\Main', False) ;
try
WriteString('Start Page', PageName) ;
Result := True;
except
Result := False;
end;
CloseKey;
finally
Free;
end;
end;
//Usage:
SetIEHomePage('http://delphi.about.com')

[Vahid_moghaddam]

function GetNetworkDriveMappings (SList: TStrings): integer;
var
c: Char;
ThePath: string;
MaxNetPathLen: DWord;
begin
SList.Clear;
MaxNetPathLen := MAX_PATH;
SetLength(ThePath, MAX_PATH) ;
for c := 'A' to 'Z' do
if WNetGetConnection(PChar('' + c + ':'), PChar(ThePath),MaxNetPathLen) = NO_ERROR then sList.Add(c + ': ' + ThePath) ;
Result := SList.Count;
end;

[hr110]

با تشکر از دوستانی که در این تاپیک فعالیت میکنند،
پیشنهاد میکنم که در پست اول عنوان نکته و آدرس ذکر شود :
1- کاربرانی که مراجعه می‌کنند به سرعت بتوانند به نکات دسترسی پیدا کنند.
2- پستهای تکراری اضافه نشوند.

این کار را حقیر برای چند مورد ، در پست اول با اجازه آقا محمد انجام می‌دهم.

[Vahid_moghaddam]

uses Registry;

function SetScreenSaver(FullSCRName : string):boolean;
var Reg: TRegistry;
begin
Reg := TRegistry.Create;
Result:=True;
with Reg do begin
try
RootKey := HKEY_CURRENT_USER;
if OpenKey('\Control Panel\Desktop', TRUE) then
begin
WriteString('SCRNSAVE.EXE',
ExtractShortPathName (FullSCRName)) ;
BroadCastSystemMessage
(0, @r, WM_SETTINGCHANGE, 0, 0) ;
SystemParametersInfo
(SPI_SETSCREENSAVEACTIVE,10,@b,0) ;
end
else Result:=False;
Finally
Free;
end; //try
end;//with
end;

{
Usage:
SetScreenSaver('C:\MyData\SFXScreenSave.SCR') ;
}

[Vahid_moghaddam]

در این کد، از تابع GetTickCount که از توابع API می باشد، استفاده شده است. این تابع میلی ثانیه های سپری شده از زمان اجرای ویندوز را بر می گرداند. این کد این زمان را به فرمت مناسب تری تبدیل می کند. هدف از گذاشتن این کدها بیشتر آشنایی با چگونگی کار با توابع مختلف دلفی و API می باشد.



function WindowsUpTime : string ;
function MSecToTime(mSec: Integer): string;
const
secondTicks = 1000;
minuteTicks = 1000 * 60;
hourTicks = 1000 * 60 * 60;
dayTicks = 1000 * 60 * 60 * 24;
var
D, H, M, S: string;
ZD, ZH, ZM, ZS: Integer;
begin
ZD := mSec div dayTicks;
Dec(mSec, ZD * dayTicks) ;
ZH := mSec div hourTicks;
Dec(mSec, ZH * hourTicks) ;
ZM := mSec div hourTicks;
Dec(mSec, ZM * minuteTicks) ;
ZS := mSec div secondTicks;
D := IntToStr(ZD) ;
H := IntToStr(ZH) ;
M := IntToStr(ZM) ;
S := IntToStr(ZS) ;
Result := D + '.' + H + ':' + M + ':' + S;
end;
begin
result := MSecToTime(GetTickCount) ;
end;

[Vahid_moghaddam]

unit WindowsUser;

interface
uses Windows;

//returns True if the currently logged Windows user has Administrator rights
function IsWindowsAdmin: Boolean;

implementation

const
SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5)) ;

const
SECURITY_BUILTIN_DOMAIN_RID = $00000020;
DOMAIN_ALIAS_RID_ADMINS = $00000220;


function IsWindowsAdmin: Boolean;
var
hAccessToken: THandle;
ptgGroups: PTokenGroups;
dwInfoBufferSize: DWORD;
psidAdministrators: PSID;
g: Integer;
bSuccess: BOOL;
begin
Result := False;

bSuccess := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, hAccessToken) ;
if not bSuccess then
begin
if GetLastError = ERROR_NO_TOKEN then
bSuccess := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, hAccessToken) ;
end;


if bSuccess then
begin
GetMem(ptgGroups, 1024) ;

bSuccess := GetTokenInformation(hAccessToken, TokenGroups, ptgGroups, 1024, dwInfoBufferSize) ;

CloseHandle(hAccessToken) ;

if bSuccess then
begin
AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, psidAdministrators) ;

for g := 0 to ptgGroups.GroupCount - 1 do
if EqualSid(psidAdministrators, ptgGroups.Groups[g].Sid) then
begin
Result := True;
Break;
end;

FreeSid(psidAdministrators) ;
end;

FreeMem(ptgGroups) ;
end;
end;

end.

[Vahid_moghaddam]

uses Math;

function RGBtoCMYK(const rgbColor : TRGBColor) : TCMYKColor;
begin
with Result do
begin
Cyan := 1 - rgbColor.Red;
Magenta := 1 - rgbColor.Green;
Yellow := 1 - rgbColor.Blue;

KeyPlate := Min(Min(Cyan, Magenta), Yellow) ;

Cyan := Cyan - KeyPlate;
Magenta := Magenta - KeyPlate;
Yellow := Yellow - KeyPlate;
end;
end;



استفاده به صورت:




var
rgbColor : TRGBColor;
cmykColor : TCMYKColor;
begin
rgbColor.Red := 128;
rgbColor.Green := 64;
rgbColor.Blue := 192;

cmykColor := RGBtoCMYK(rgbColor) ;

Caption := Format('%d-%d-%d-%d',[cmykColor.Cyan, cmykColor.Magenta, cmykColor.Yellow, cmykColor.KeyPlate])
end;

[Vahid_moghaddam]

uses shlobj, ...

function GetMyDocuments: string;
var
r: Bool;
path: array[0..Max_Path] of Char;
begin
r := ShGetSpecialFolderPath(0, path, CSIDL_Personal, False) ;
if not r then raise Exception.Create('Could not find MyDocuments folder location.') ;
Result := Path;
end;

procedure TMyForm.FormCreate(Sender: TObject) ;
var
myDocFolder : string;
begin
myDocFolder := GetMyDocuments;
ShowMessage(Format('MyDocuments folder for the current user: "%s"',[myDocFolder])) ;
end;

[Cave_Man]

procedure TForm1.Button1Click(Sender: TObject);
var
F: TStream;
UnicodeString: WideString;
UnicodeSign: Word;
FileName: string;
FileSize: Cardinal;
begin
FileName := 'SchedLgU.Txt';
F := TFileStream.Create(FileName, fmOpenRead);
try
FileSize := F.Size;
if FileSize >= SizeOf(UnicodeSign) then
begin
F.ReadBuffer(UnicodeSign, SizeOf(UnicodeSign));
if UnicodeSign = $FEFF then
begin
Dec(FileSize, SizeOf(UnicodeSign));
SetLength(UnicodeString, FileSize div SizeOf(WideChar));
F.ReadBuffer(UnicodeString[1], FileSize);
// now UnicodeString contains Unicode string read from stream
Memo1.Lines.Text := UnicodeString;
end
else
// not a Unicode format;
Memo1.Lines.LoadFromFile(FileName);
end;
finally
F.Free;
end;
end;

[ParsaNM]

تغییر اندازه کلید Start..






procedure TForm1.Button1Click(Sender: TObject);
begin
MoveWindow(FindWindowEx(FindWindow('Shell_TrayWnd' , nil), 0, 'Button', nil),
300, 0, 80, 22, true);
end;

[ParsaNM]

چک کردن اینکه آیا فایل در Local Drive می باشد.


function IsOnLocalDrive(aFileName: string): Boolean;
var
aDrive: string;
begin
aDrive := ExtractFileDrive(aFileName);
if (GetDriveType(PChar(aDrive)) = DRIVE_REMOVABLE) or
(GetDriveType(PChar(aDrive)) = DRIVE_FIXED) then
Result := True
else
Result := False;
end;


// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
if IsOnLocalDrive(OpenDialog1.FileName) then
ShowMessage(OpenDialog1.FileName + ' is on a local drive.');
end;

[ParsaNM]

چک کردن اینکه پارتیشن Fat میباشد یا NTFS





function GetHardDiskPartitionType(const DriveLetter: Char): string;
var
NotUsed: DWORD;
VolumeFlags: DWORD;
VolumeInfo: array[0..MAX_PATH] of Char;
VolumeSerialNumber: DWORD;
PartitionType: array[0..32] of Char;
begin
GetVolumeInformation(PChar(DriveLetter + ':\'),
nil, SizeOf(VolumeInfo), @VolumeSerialNumber, NotUsed,
VolumeFlags, PartitionType, 32);
Result := PartitionType;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetHardDiskPartitionType('c'));
ShowMessage(GetHardDiskPartitionType('a'));
end;

[ParsaNM]

چک کردن اینکه آیا سرویسی مورد نظر start می باشد






uses
WinSvc;

function ServiceGetStatus(sMachine, sService: PChar): DWORD;
{******************************************}
{*** Parameters: ***}
{*** sService: specifies the name of the service to open
{*** sMachine: specifies the name of the target computer
{*** ***}
{*** Return Values: ***}
{*** -1 = Error opening service ***}
{*** 1 = SERVICE_STOPPED ***}
{*** 2 = SERVICE_START_PENDING ***}
{*** 3 = SERVICE_STOP_PENDING ***}
{*** 4 = SERVICE_RUNNING ***}
{*** 5 = SERVICE_CONTINUE_PENDING ***}
{*** 6 = SERVICE_PAUSE_PENDING ***}
{*** 7 = SERVICE_PAUSED ***}
{******************************************}
var
SCManHandle, SvcHandle: SC_Handle;
SS: TServiceStatus;
dwStat: DWORD;
begin
dwStat := 0;
// Open service manager handle.
SCManHandle := OpenSCManager(sMachine, nil, SC_MANAGER_CONNECT);
if (SCManHandle > 0) then
begin
SvcHandle := OpenService(SCManHandle, sService, SERVICE_QUERY_STATUS);
// if Service installed
if (SvcHandle > 0) then
begin
// SS structure holds the service status (TServiceStatus);
if (QueryServiceStatus(SvcHandle, SS)) then
dwStat := ss.dwCurrentState;
CloseServiceHandle(SvcHandle);
end;
CloseServiceHandle(SCManHandle);
end;
Result := dwStat;
end;

function ServiceRunning(sMachine, sService: PChar): Boolean;
begin
Result := SERVICE_RUNNING = ServiceGetStatus(sMachine, sService);
end;

// Check if Eventlog Service is running
procedure TForm1.Button1Click(Sender: TObject);
begin
if ServiceRunning(nil, 'Eventlog') then
ShowMessage('Eventlog Service Running')
else
ShowMessage('Eventlog Service not Running')
end;

[ParsaNM]

چک کردن اینکه آیا Sound card نصب شده است





uses
MMSystem;

function SoundCardAvailable: Boolean;
begin
Result := WaveOutGetNumDevs > 0;
end;

[ParsaNM]

چک کردن اینکه آیا دلفی در حال اجراست





function WindowExists(AppWindowName, AppClassName: string): Boolean;
var
hwd: LongWord;
begin
hwd := 0;
hwd := FindWindow(PChar(AppWindowName), PChar(AppClassName));
Result := False;
if not (Hwd = 0) then {window was found if not nil}
Result := True;
end;

function DelphiLoaded: Boolean;
begin
DelphiLoaded := False;
if WindowExists('TPropertyInspector', 'Object Inspector') then
if WindowExists('TMenuBuilder', 'Menu Designer') then
if WindowExists('TAppBuilder', '(AnyName)') then
if WindowExists('TApplication', 'Delphi') then
if WindowExists('TAlignPalette', 'Align') then
DelphiLoaded := True;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if DelphiLoaded then
begin
ShowMessage('Delphi is running');
end;
end;

function DelphiIsRunning: Boolean;
begin
Result := DebugHook <> 0;
end;

[ParsaNM]

پیدا کردن و بارگذاری Icon داخل فایل





uses
shellApi;

{...}

procedure TForm1.Button1Click(Sender: TObject);
const
ExtrFileName = 'C:\WINNT\system32\moricons.dll';
var
icon: TIcon;
NumberOfIcons, i: Integer;
begin
icon := TIcon.Create;
try
// Get the number of Icons
NumberOfIcons := ExtractIcon(Handle, PChar(ExtrFileName), UINT(-1));
ShowMessage(Format('%d Icons', [NumberOfIcons]));
// Extract the first 5 icons
for i := 1 to 5 do
begin
// Extract an icon
icon.Handle := ExtractIcon(Handle, PChar(ExtrFileName), i);
// Draw the icon on your form
DrawIcon(Form1.Canvas.Handle, 10, i * 40, icon.Handle);
end;
finally
icon.Free;
end;
end;

[babak_delphi]

با این تابع می توانید ولوم سریالِ دیسک را بدست آوردید



Function GetDiscVolSerialID(cDriveName : char) :DWORD;
var
dwtemp1,dwtemp2 : DWORD;
begin
GetVolumeInformation(PChar(cDriveName + ':\'),Nil,0,@Result , dwtemp1 ,dwtemp2,Nil, 0);
end;

[babak_delphi]

تابعی که میشه اون رو در رویدادهای کیبورد برای Edit قرار داد تا فقط عدد بگیره



Function IsNum(ch : char) : char;
begin
if Pos(ch,#8#13'1234567890') = 0 then
ch := #0;
Result := ch;
end;

[babak_delphi]

برای اینکه بعد از اجرای برنامه اگر کاربر روی آیکن برنامه کلیک کرد ، همزمان چند نسخه از اون اجرا نشه می تونیم فایل DPR پروژه رو بصورت زیر تغییر بدیم



uses
windows;
var
hmutex : THandle;
begin
hmutex := CreateMutex(nil,false,'OneCopyMutex');
if waitforsingleobject(hmutex, 0) <> wait_timeout then
begin
Application.Initialize;
.
.
.
Application.Run;
end;
end.

[computer-mag]

تغییر رزولوشن مانیتور





function SetDisplay1024x768: Boolean;
var
DevMode: TDeviceMode;
begin
EnumDisplaySettings(nil, 0, DevMode);
DevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;
DevMode.dmPelsWidth := 1024;
DevMode.dmPelsHeight := 768;
Result := ChangeDisplaySettings(DevMode, CDS_UPDATEREGISTRY)
= DISP_CHANGE_SUCCESSFUL;
end;


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

[babak_delphi]

در اکثر فرمهایی که برای دریافت اطلاعات از کاربر هستند ، معمولا دکمه ای داریم که برای پاک کردن فرم یا در حقیقت پاک کردن محتوای Edit ها بکار میره
میتونید کد زیر رو برای این دکمه قرار بدین تا لازم نباشه که برای هر فرم تک تک edit ها رو بنویسید
این کد به این صورت کار میکنه که روی فرم تمام Edit ها رو پیدا میکنه و اونها رو Clear می کنه


procedure clear_Edits;
var
cnt : integer;
begin
for cnt := 0 to ComponentCount - 1 do
begin
if Components[cnt].ClassName = 'TEdit' then
TEdit(Components[cnt]).Clear
end;
end;


حالا اگه توابعتون رو در یک کتابخونه نگهداری می کنید و اون Unit رو در فرمتون Use می کنید ، می تونید این تابع رو به شکل زیر تغییر بدین تا با فراخوانی از یک Unit دیگه هم بدرستی کار کنه



procedure clear_Edits;
var
cnt : integer;
begin
for cnt := 0 to Screen.ActiveForm.ComponentCount - 1 do
begin
if (Screen.ActiveForm.Components[cnt].ClassName = 'TEdit') then
TEdit(Screen.ActiveForm.Components[cnt]).Clear
end;
end

[مهران موسوی]

چک کردن خالی بودن یک مسیر


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

[مهران موسوی]

فایل مورد نظر باینری است یا نوشتاری ؟؟


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

[مهران موسوی]

چگونه فایلهای INI را نصب کنیم ؟


uses
ShellAPI;

function InstallINF(const PathName: string; hParent: HWND): Boolean;
var
instance: HINST;
begin
instance := ShellExecute(hParent,
PChar('open'),
PChar('rundll32.exe'),
PChar('setupapi,InstallHinfSection DefaultInstall 132 ' + PathName),
nil,
SW_HIDE);

Result := instance > 32;
end;

[مهران موسوی]

چگونه تعداد ایتمها ی ListBox را با API بدست اوریم ؟




function LB_GetItemCount(hListBox: THandle): Integer;
begin
Result := SendMessage(hListBox, LB_GETCOUNT, 0, 0);
end;

[مهران موسوی]

چگونه یک ایتم ListBox را با API حذف کنیم ؟


procedure LB_DeleteItem(hListBox: THandle; Index: Integer);
begin
SendMessage(hListBox, LB_DELETESTRING, Index, 0);
end;

[مهران موسوی]

چگونه ایتم انتخاب شده ی ListBox را توسط API بدست اوریم ؟


function LB_GetSelectedItem(hListBox: THandle): string;
var
Index, len: Integer;
s: string;
buffer: PChar;
begin
Index := SendMessage(hListBox, LB_GETCURSEL, 0, 0);
len := SendMessage(hListBox, LB_GETTEXTLEN, wParam(Index), 0);
GetMem(buffer, len + 1);
SendMessage(hListBox, LB_GETTEXT, wParam(Index), lParam(buffer));
SetString(s, buffer, len);
FreeMem(buffer);
Result := IntToStr(Index) + ' : ' + s;
end;

[مهران موسوی]

گرفتن ایتم یک ایتم ListBox توسط API


function LB_GetListBoxItem(hWnd: Hwnd; LbItem: Integer): string;
var
l: Integer;
buffer: PChar;
begin
l := SendMessage(hWnd, LB_GETTEXTLEN, LbItem, 0);
GetMem(buffer, l + 1);
SendMessage(hWnd, LB_GETTEXT, LbItem, Integer(buffer));
Result := StrPas(buffer);
FreeMem(buffer);
end;

[مهران موسوی]

بدست اوردن تمامی ایتم های یک ListBox توسط API


function LB_GetAllItems(hWnd: Hwnd; sl: TStrings): string;
var
RetBuffer: string;
i, x, y: Integer;
begin
x := SendMessage(hWnd, LB_GETCOUNT, 0, 0);
for i := 0 to x - 1 do
begin
y := SendMessage(hWnd, LB_GETTEXTLEN, i, 0);
SetLength(RetBuffer, y);
SendMessage(hWnd, LB_GETTEXT, i, lParam(PChar(RetBuffer)));
sl.Add(RetBuffer);
end;
end;

[مهران موسوی]

تغییر نام یک پوشه ....


uses
ShellApi;

procedure RenameDir(DirFrom, DirTo: string);
var
shellinfo: TSHFileOpStruct;
begin
with shellinfo do
begin
Wnd := 0;
wFunc := FO_RENAME;
pFrom := PChar(DirFrom);
pTo := PChar(DirTo);
fFlags := FOF_FILESONLY or FOF_ALLOWUNDO or
FOF_SILENT or FOF_NOCONFIRMATION;
end;
SHFileOperation(shellinfo);
end;

[مهران موسوی]

باز کردن یک پوشه توسط Windows Explorer


procedure ShowFolder(strFolder: string);
begin
ShellExecute(Application.Handle,
PChar('explore'),
PChar(strFolder),
nil,
nil,
SW_SHOWNORMAL);
end;

[مهران موسوی]

بدست اوردن مالک ( Owner ) یک فایل


function GetFileOwner(FileName: string;
var Domain, Username: string): Boolean;
var
SecDescr: PSecurityDescriptor;
SizeNeeded, SizeNeeded2: DWORD;
OwnerSID: PSID;
OwnerDefault: BOOL;
OwnerName, DomainName: PChar;
OwnerType: SID_NAME_USE;
begin
GetFileOwner := False;
GetMem(SecDescr, 1024);
GetMem(OwnerSID, SizeOf(PSID));
GetMem(OwnerName, 1024);
GetMem(DomainName, 1024);
try
if not GetFileSecurity(PChar(FileName),
OWNER_SECURITY_INFORMATION,
SecDescr, 1024, SizeNeeded) then
Exit;
if not GetSecurityDescriptorOwner(SecDescr,
OwnerSID, OwnerDefault) then
Exit;
SizeNeeded := 1024;
SizeNeeded2 := 1024;
if not LookupAccountSID(nil, OwnerSID, OwnerName,
SizeNeeded, DomainName, SizeNeeded2, OwnerType) then
Exit;
Domain := DomainName;
Username := OwnerName;
finally
FreeMem(SecDescr);
FreeMem(OwnerName);
FreeMem(DomainName);
end;
GetFileOwner := True;
end;

[مهران موسوی]

مقایسه ی اندازه ی دو فایل


function Are2FilesEqual(const File1, File2: TFileName): Boolean;
var
ms1, ms2: TMemoryStream;
begin
Result := False;
ms1 := TMemoryStream.Create;
try
ms1.LoadFromFile(File1);
ms2 := TMemoryStream.Create;
try
ms2.LoadFromFile(File2);
if ms1.Size = ms2.Size then
Result := CompareMem(ms1.Memory, ms2.memory, ms1.Size);
finally
ms2.Free;
end;
finally
ms1.Free;
end
end;

[مهران موسوی]

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


function GetFileModifyDate(FileName: string): TDateTime;
var
h: THandle;
Struct: TOFSTRUCT;
lastwrite: Integer;
t: TDateTime;
begin
h := OpenFile(PChar(FileName), Struct, OF_SHARE_DENY_NONE);
try
if h <> HFILE_ERROR then
begin
lastwrite := FileGetDate(h);
Result := FileDateToDateTime(lastwrite);
end;
finally
CloseHandle(h);
end;
end;

[مهران موسوی]

ایا فایل ما ASCII است ؟




function isAscii(NomeFile: string): Boolean;
const
SETT = 2048;
var
i: Integer;
F: file;
a: Boolean;
TotSize, IncSize, ReadSize: Integer;
c: array[0..Sett] of Byte;
begin
if FileExists(NomeFile) then
begin
{$I-}
AssignFile(F, NomeFile);
Reset(F, 1);
TotSize := FileSize(F);
IncSize := 0;
a := True;
while (IncSize < TotSize) and (a = True) do
begin
ReadSize := SETT;
if IncSize + ReadSize > TotSize then ReadSize := TotSize - IncSize;
IncSize := IncSize + ReadSize;
BlockRead(F, c, ReadSize);
// Iterate
for i := 0 to ReadSize - 1 do
if (c < 32) and (not (c[i] in [9, 10, 13, 26])) then a := False;
end; [I]{ while }
CloseFile(F);
{$I+}
if IOResult <> 0 then Result := False
else
Result := a;
end;
end;

[مهران موسوی]

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


function Get_File_Size1(sFileToExamine: string; bInKBytes: Boolean): string;
var
FileHandle: THandle;
FileSize: LongWord;
d1: Double;
i1: Int64;
begin
//a- Get file size
FileHandle := CreateFile(PChar(sFileToExamine),
GENERIC_READ,
0, {exclusive}
nil, {security}
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
FileSize := GetFileSize(FileHandle, nil);
Result := IntToStr(FileSize);
CloseHandle(FileHandle);
//a- optionally report back in Kbytes
if bInKbytes = True then
begin
if Length(Result) > 3 then
begin
Insert('.', Result, Length(Result) - 2);
d1 := StrToFloat(Result);
Result := IntToStr(round(d1)) + 'KB';
end
else
Result := '1KB';
end;
end;

[مهران موسوی]

کپی کردن یک پوشه


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;

[مهران موسوی]

گرفتن مسیر جاری


label1.Caption := GetCurrentDir;

تغییر مسیر جاری


SetCurrentDir('c:\windows');

[مهران موسوی]

کپی کردن فایل


var
fileSource, fileDest: string;
begin
fileSource := 'C:\SourceFile.txt';
fileDest := 'G:\DestFile.txt';
CopyFile(PChar(fileSource), PChar(fileDest), False);
end;

[مهران موسوی]

خواندن Version Info یک فایل


function GetVersion: string;
var
VerInfoSize: DWORD;
VerInfo: Pointer;
VerValueSize: DWORD;
VerValue: PVSFixedFileInfo;
Dummy: DWORD;
begin
Result := '';
VerInfoSize := GetFileVersionInfoSize(PChar(ParamStr(0)), Dummy);
if VerInfoSize = 0 then Exit;
GetMem(VerInfo, VerInfoSize);
GetFileVersionInfo(PChar(ParamStr(0)), 0, VerInfoSize, VerInfo);
VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
with VerValue^ do
begin
Result := IntToStr(dwFileVersionMS shr 16);
Result := Result + '.' + IntToStr(dwFileVersionMS and $FFFF);
Result := Result + '.' + IntToStr(dwFileVersionLS shr 16);
Result := Result + '.' + IntToStr(dwFileVersionLS and $FFFF);
end;
FreeMem(VerInfo, VerInfoSize);
end;

[مهران موسوی]

ریختن یک فایل در سطل زباله ویندوز ...


uses ShellAPI;

function DeleteFileWithUndo(sFileName: string): Boolean;
var
fos: TSHFileOpStruct;
begin
FillChar(fos, SizeOf(fos), 0);
with fos do
begin
wFunc := FO_DELETE;
pFrom := PChar(sFileName);
fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT;
end;
Result := (0 = ShFileOperation(fos));
end;

[babak_delphi]

نحوه تبدیل Date به عدد
البته فرمت ورودی باید string باشه مثلا (29/01/1387)
خروجی هم یک string با فرمت عددی است مثل : "13870129"



Function DATE_TO_INT(Str : string) : String;
var
temp,con : string;
p : ^String;
begin
if str <> ' / / ' then
begin
p := @temp;
temp := Trim(PChar(Str));
con := p^[1] + p^[2] + p^[3] + p^[4] + p^[6] + p^[7] + p^[9] + p^[10];
DATE_TO_INT := con;
end
else
DATE_TO_INT := '0';
end;

[babak_delphi]

نحوه تبدیل عدد به Date
البته فرمت ورودی باید string باشه مثلا "13870129"
خروجی هم یک string به شکل تاریخ است مثل : "29/01/1387"



Function INT_TO_DATE(Str : string) : String;
var
temp,con : string;
p : ^String;
begin
if (str <> '0') AND (str <> '') AND (str <> NULL)then
begin
p := @temp;
temp := Trim(PChar(Str));
con := p^[1] + p^[2] + p^[3] + p^[4] +'/' + p^[5] + p^[6] + '/' +p^[7] + p^[8];
INT_TO_DATE := con;
end
else
INT_TO_DATE := '';
end;

[babak_delphi]

نحوه تبدیل Time به عدد
البته فرمت ورودی باید string باشه مثلا (12:04)
خروجی هم یک string با فرمت عددی است مثل : "12:04"



Function TIME_TO_INT(Str : string) : String;
var
temp,con : string;
p : ^String;
begin
if str <> ' : ' then
begin
p := @temp;
temp := Trim(PChar(Str));
con := p^[1] + p^[2] + p^[4] + p^[5];
TIME_TO_INT := con;
end
else
TIME_TO_INT := '0';
end;

[babak_delphi]

نحوه تبدیل عدد به Time
البته فرمت ورودی باید string باشه مثلا "12:04"
خروجی هم یک string به شکل ساعت است است مثل : "12:04"



Function INT_TO_TIME(Str : string) : String;
var
temp,con : string;
p : ^String;
begin
if (str <> '0') AND (str <> '') AND (str <> NULL)then
begin
p := @temp;
temp := Trim(PChar(Str));
con := p^[1] + p^[2] + ':' + p^[3] + p^[4];
INT_TO_TIME := con;
end
else
INT_TO_TIME := '';
end;

[babak_delphi]

شما می تونید این 4 تابع رو برای ذخیره سازی اطلاعات در پایگاه داده و بازیابی اوو استفاده کنید
به این صورت که برای ذخیره تاریخ می تونید یک فیلد integer داشته باشید و تاریخ رو بصورت عددی (با حذف /)در اون قرار بدید و بعد از بازیابی با توابع مربوطه / ها رو اضافه کنید و نمایش بدید
علت ذخیره در Database بصورت Integer اینه که سرعت عملیات روی Integer زیاده
بعد برای مشاهده می تونید اون رو به فرمت string (چون control هایی مثل Edit و Label که معمولا از اونها برای نمایش استفاده می شود string می گیرند) تبدیل کنید
برای ذخیره هم می تونید این توابع رو تغییر بدید که مثلا برای تاریخ علاوه بر حذف / ها ، اون رو به Integer تبدیل کنه و هم اینکه می تونید با StrToInt این کار رو انجام بدید.

[babak_delphi]

لازم به توضیح است که توابعی را که من معرفی می کنم را بهتر است که به این صورت استفاده کنید
همه آنها را در یک Unit ذخیره کنید
در فرم هایی که می خواهید آن توابع را استفاده کنید Unit مذبور را در فرم Use کنید و توابع را فراخوانی کنید
من توابع را معمولا طوری می نویسم که عمومی باشد و به این صورت بتوان استفاده کرد
برای توابع دیگر را نیز می توان همین کار را انجام داد

[babak_delphi]

در فرم هایی که برای ورود اطلاعات استفاده می شوند می تونید این تابع را در OnClick دکمه ذخیره سازی و قبل از ذخیره اطلاعات استفاده کنید
این تابع تمام Edit های روی فرم را شناسایی کرده و آنها را Trim می کند



procedure Trim_Edit;
var
cnt : integer;
begin
for cnt := 0 to Screen.ActiveForm.ComponentCount - 1 do
if (Screen.ActiveForm.Components[cnt].ClassName = 'TEdit') then
TEdit(Screen.ActiveForm.Components[cnt]).Text :=
Trim(TEdit(Screen.ActiveForm.Component[cnt]).Text);
end;

[babak_delphi]

این هم مشابه تابع قبلی است با این تفاوت که بجای Edit برای DBEdit مورد استفاده قرار می گیرد
شما می توانید این 2 تابع را ادغام کنید و طوری تغییر بدید که یک تابع داشته باشید که برای هر 2 حالت جواب دهد.



procedure Trim_DBEdit;
var
cnt : integer;
begin
for cnt := 0 to Screen.ActiveForm.ComponentCount - 1 do
if (Screen.ActiveForm.Components[cnt].ClassName = 'TDBEdit') then
TDBEdit(Screen.ActiveForm.Components[cnt]).Text :=
Trim(TDBEdit(Screen.ActiveForm.Components[cnt]).Text);
end;

[babak_delphi]

یک فایل هست که شامل چند تابع از جمله تبدیل عدد به حروف ، سه رقم سه رقم جدا کردن اعداد و ... است
این فایل رو hadisalahi2 (http://barnamenevis.org/forum/member.php?u=54383) در قسمت دلفی Upload کرده بود

[babak_delphi]

Function MiladiToHejri(GregorianDate : String;DateType : Integer) : String;
var
jmm, jdd : string;
g_days_in_month, j_days_in_month : array[0..11] of Integer;
HijriMonths : array[1..12] of String;
g_day_no, j_day_no, jy, jm, gy, gm : Longint;
j_np, i, jd, GD : Integer;
flag : Boolean;
begin
Try
flag := true;
g_days_in_month[0] := 31;
g_days_in_month[1] := 28;
g_days_in_month[2] := 31;
g_days_in_month[3] := 30;
g_days_in_month[4] := 31;
g_days_in_month[5] := 30;
g_days_in_month[6] := 31;
g_days_in_month[7] := 31;
g_days_in_month[8] := 30;
g_days_in_month[9] := 31;
g_days_in_month[10] := 30;
g_days_in_month[11] := 31;
j_days_in_month[0] := 31;
j_days_in_month[1] := 31;
j_days_in_month[2] := 31;
j_days_in_month[3] := 31;
j_days_in_month[4] := 31;
j_days_in_month[5] := 31;
j_days_in_month[6] := 30;
j_days_in_month[7] := 30;
j_days_in_month[8] := 30;
j_days_in_month[9] := 30;
j_days_in_month[10] := 30;
j_days_in_month[11] := 29;
If GregorianDate = Null Then Exit;
gy := (StrToInt(FormatDateTime('yyyy', StrToDate(GregorianDate)))) - 1600 ;
gm := (StrToInt(FormatDateTime('mm', StrToDate(GregorianDate)))) - 1 ;
GD := (StrToInt(FormatDateTime('dd', StrToDate(GregorianDate)))) - 1 ;
g_day_no := 365 * gy + (gy + 3) div 4 - (gy + 99) div 100 + ( gy + 399) div 400;
i := 0;
While i < gm do
begin
g_day_no := g_day_no + g_days_in_month[i];
i := i + 1;
end;
If (gm > 1) And (((gy Mod 4 = 0) And (gy Mod 100 <> 0)) Or (gy Mod 400 = 0)) Then
g_day_no := g_day_no + 1;
g_day_no := g_day_no + GD;
j_day_no := g_day_no - 79;
j_np := j_day_no div 12053;
j_day_no := j_day_no Mod 12053;
jy := 979 + 33 * j_np + 4 * (j_day_no div 1461);
j_day_no := j_day_no Mod 1461;
If (j_day_no >= 366) Then
begin
jy := jy + (j_day_no - 1) div 365;
j_day_no := (j_day_no - 1) Mod 365;
End;
i := 0;
While (j_day_no >= j_days_in_month[i]) and flag do
begin
j_day_no := j_day_no - j_days_in_month[i];
i := i + 1;
If i > 12 Then
begin
i := 11;
j_day_no := 29;
flag := False;
End;
end;
jm := i + 1;
jd := j_day_no + 1;
jmm := IntToStr(jm);
jdd := IntToStr(jd);
If (Length(jmm) = 1) then
jmm := '0' + jmm
else
jmm := jmm;
if (Length(jdd) = 1) then
jdd := '0' + jdd
else
jdd := jdd;
HijriMonths[1] := 'فروردین';
HijriMonths[2] := 'اردیبهشت';
HijriMonths[3] := 'خرداد';
HijriMonths[4] := 'تیر';
HijriMonths[5] := 'مرداد';
HijriMonths[6] := 'شهریور';
HijriMonths[7] := 'مهر';
HijriMonths[8] := 'آبان';
HijriMonths[9] := 'آذر';
HijriMonths[10] := 'دی';
HijriMonths[11] := 'بهمن';
HijriMonths[12] := 'اسفند';
if jmm = '13' then
begin
jmm := '12';
jdd := '30';
end;
Case DateType of
0:
MiladiToHejri := IntToStr(jy) + '/' + jmm + '/' + jdd;
1:
MiladiToHejri := IntToStr(strtoint(jdd)) + ' ' + HijriMonths[StrToInt(jmm)] + ' ' + IntToStr(jy);
End;
except
MiladiToHejri := 'تاریخ وارد شده، اشتباه می باشد .';
end;
End;

[babak_delphi]

Function HijriToMiladi(HijriDate : String;DateType : Integer) : String;
var
jy, jm, jd, Hd, Gd,y ,m, tmp, jmmm, jddd, jyyy : string;
c : Integer;
MiladiMonths : array[1..12] of String;
{ If HijriDate = NULL Then Exit;
If Len(HijriDate) < 10 Then
MsgBox "تاریخ وارد شده، اشتباه می باشد
Exit Function
End If}
//1382/02/03
begin
jy := Copy(HijriDate,1,4);

jm := copy(HijriDate, 6, 2);
If (Length(jm) = 1) then
jm := '0' + jm
else
jm := jm;
jd := copy(HijriDate,9,2);
if (copy(jd,1,1) = '/' ) then
jd := '0' + copy(jd,2,1)
else
jd := jd;
// 'jd = IIf(Len(jd) = 1, "0" & jd, jd)

HD := jy + '/' + jm + '/' + jd;
Case StrToInt(jm) of
1, 2, 3, 4, 5, 6, 7, 8, 9, 10 :
begin
m := IntToStr(StrToInt(jm) + 2);
Y := IntToStr(StrToInt(jy) + 621);
end;
11, 12 :
begin
m := '0' + copy(jm,2,1);
Y := IntToStr(StrToInt(jy) + 622);
end
End;//case
GD := Y + '/' + m + '/01';
//' GD = Y & "/01/01"
c := 0;
While True do
begin
tmp := GD;
If HD = MiladiToHejri(GD,0) Then
break;
// GD := DateAdd('d', 1, GD);
GD := DateToStr(strtoDate(tmp)+ 1);
c := c + 1;
If c > 1000 Then
begin
// ' MsgBox "Date conversion error. Please check entered date.", vbCritical, "Error"
HijriToMiladi := '. تاریخ وارد شده، اشتباه می باشد ';
Exit;
end;
end;//while
MiladiMonths[1] := 'January';
MiladiMonths[2] := 'February';
MiladiMonths[3] := 'March';
MiladiMonths[4] := 'April';
MiladiMonths[5] := 'May';
MiladiMonths[6] := 'June';
MiladiMonths[7] := 'July';
MiladiMonths[8] := 'August';
MiladiMonths[9] := 'September';
MiladiMonths[10] := 'October';
MiladiMonths[11] := 'November';
MiladiMonths[12] := 'December';
Case DateType of
0:
HijriToMiladi := GD;
1:
begin
jyyy := copy(GD,1,4);
jmmm := copy(GD,6,2);
if (copy(jmmm,2,1) = '/' ) then
jmmm := '0' + copy(jmmm,1,1)
else
jmmm := jmmm;
jddd := copy(GD,Length(GD)-1,2);
if (copy(jddd,1,1) = '/' ) then
jddd := '0' + copy(jddd,2,1)
else
jddd := jddd;
HijriToMiladi := IntToStr(strtoint(jddd))+'th of' + ' ' + MiladiMonths[StrToInt(jmmm)] + ' '+jyyy;
end;
End;
End;

[babak_delphi]

این کد در حقیقت برای رفتن به تب بعدی روی فرم است.


procedure Go_Next_Tab(Key : Char);
begin
Try
if (Key = #13) then
begin
PostMessage(Screen.ActiveForm.Handle, WM_NEXTDLGCTL, 0, 0);
Key := #0;
end;
Except
Application.MessageBox(' !!! یک اشکال ناشناخته در روند انجام کار پیش آمده است ','ERROR',MB_OK + MB_ICONERROR);
end;
end;

[delphiprog3000]

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

اشیا مورد استفاده از تب Dialog



Open Dialog -1


Save Dialog -2

ور در ادامه کدها :




باز کردن فایل:


procedure TForm1.Button1Click(Sender: TObject);
var
i:integer;
temp:byte;
begin
if opendialog1.Execute then
begin
assignfile(f,opendialog1.FileName);
reset(F);
showmessage(inttostr(filesize(f)));
size:=FileSize(f);
for i :=0 to filesize(f)-1 do
read(f,datafile[i]);
for I := 0 to FileSize(f) do
begin
datafile2[i]:=datafile[i];
end;



تبدیل یا Encode فایل:



procedure TForm1.Button3Click(Sender: TObject);
var i:integer;
begin
for I := 0 to size-1 do
datafile[i]:=datafile2[i+3];
end;


بازگردان فایل یا Decode :



procedure TForm1.Button4Click(Sender: TObject);
var i:integer;
begin
for I := 0 to size-1 do
datafile[i]:=datafile2[i-3];
end;


ذخیره فایل :



procedure TForm1.Button2Click(Sender: TObject);
var
f1:file of byte;
i:integer;
begin
if savedialog1.Execute then begin
assignfile(f1,savedialog1.FileName);
rewrite(f1);
for I := 0 to size - 1 do write(f1,datafile[i]);
closefile(f1);
end;


بازهم اگر دوستان روشهای بهتری داشتن ارائه کنند.

با تشکر.موفق باشید....................

[babak_delphi]

این توضیحات مربوط به یکی از پستهای hassan razavi (http://barnamenevis.org/forum/member.php?u=5419) است که در جواب نحوه ذخیره فایل فلش در پایگاه داده ، نوشته بودند
من اون را در اینجا قرار دادم تا در دسترس عموم باشد



نحوه ذخیره فایل در بانک :

یک جدول بنام TFile در SQL Server 2000 ایجاد کنید. من در بانک Master اینکار رو کردم.
2 تا فیلد با مشخصات زیر ایجاد کنید:
1- name nvarchar key
2-swf image allow null

حالا این کد برای ذخیره در بانک (برای هر فایلی میتونید استفاده کنید) برای مثال از آدرس C:\\1.swf استفاده کردم


FileStream fs = new FileStream("d:\\1.swf",FileMode.Open);
FileInfo fi = new FileInfo("d:\\1.swf");
byte[] swf = new byte[(int)fi.Length];
fs.Read(swf, 0, (int)fi.Length);

SqlConnection con = new SqlConnection("Data Source=.;Initial Catalog=master;Persist Security Info=True;Password=1;User ID=sa");
con.Open();
SqlCommand com = new SqlCommand("Insert into TFile (name,swf) Values (@name,@swf)", con);
com.Parameters.Add("name", SqlDbType.NVarChar).Value = "1.swf";
com.Parameters.Add("swf", SqlDbType.Image).Value = swf;
com.ExecuteNonQuery();
con.Close();


اینم کد برای بازیابی از بانک (برای مثال در مسیر d:\\222.swf استفاده کردم)



SqlConnection con = new SqlConnection("Data Source=.;Initial Catalog=master;Persist Security Info=True;Password=1;User ID=sa");
con.Open();
SqlDataReader dr;
SqlCommand com = new SqlCommand("select * from TFile", con);
dr = com.ExecuteReader();
dr.Read();
byte[] swf = (byte[])dr.GetValue(1);
FileStream fs = new FileStream("d:\\222.swf", FileMode.Create);
fs.Write(swf, 0, swf.Length);
fs.Close();
con.Close();




آدرس اون تاپیک هم اینه (http://barnamenevis.org/forum/showthread.php?t=87164&page=2)

[babak_delphi]

کدی جهت اضافه کردن یک آیتم جدید به منویی که هنگام کلیک راست روی برنامه تان روی نوار فرمان ظاهر می شود



unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure OnAppMessage(Var Msg:TMsg;Var Handled:Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;
const
SC_MyMenuItem= WM_User + 1;
var
R:TRect;
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
Application.OnMessage := OnAppMessage;
AppendMenu(GetSystemMenu(Application.Handle,False) ,MF_SEPARATOR,0,'');
AppendMenu(GetSystemMenu(Application.Handle,False) ,
MF_STRING, SC_myMenuItem,'Menu Created...');
SystemParametersInfo(SPI_GETWORKAREA , 0 , @r , 0);
end;
procedure TForm1.OnAppMessage(Var Msg:TMsg;Var Handled:Boolean);
begin
if (Msg.message = WM_SYSCOMMAND)and(Msg.wParam = SC_MyMenuItem )then
begin
ShowMessage('Menu Event Occured...');
Handled := True;
end;
end;

end.

[babak_delphi]

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

هیچ کس از اول بلد نبود :چشمک:



begin
winexec(pchar('calc'),SW_shownormal);
end;

[babak_delphi]

برای نصب فایلهای ocx و dll رو در شاخه system32 ویندوز کپی کنید و در run تایپ کنید اسم فایل regsvr32
regsvr32 GSM_MODEM.OCX
بعد فایل pas یا همون gsmmodem_tlb.pas رو تو شاخه Lib دلفی کپی کنید
در آخر از منوی install component تو دلفی فایل pas رو انتخاب کنید
فکر کنم کامپوننت اضافه شده تو پالت activex دلفی اضافه میشه یا تو پالت system

[babak_delphi]

procedure TForm1.Button1Click(Sender: TObject);
var
h,m,s,ms:word;
begin
DecodeTime(Time,h,m,s,ms) ;
Label1.Caption := 'Time = ' + TimeToStr(Time) + Chr(13) +
'Hour=' + IntToStr(h) + Chr(13) +
'Min=' + IntToStr(m) + Chr(13) +
'Sec=' + IntToStr(s) + Chr(13) +
'MS=' + IntToStr(ms) ;
end;

[babak_delphi]

procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption := Format('Num1 = %d , Num2 = %d',[30,54]); //The argument must be an integer value.
Label2.Caption := Format('Copy %s to %s?', ['10','11']); //The argument must be a character, a string, or a PChar value.
Label3.Caption := Format('%.4d/%.2d/%.2d', [1385, 3, 4]) ; //Format 0 In The Date
Label4.Caption := Format('%.4d%.2d%.2d', [1385, 3, 4]) ; //Format 0 In The Date Without Slash/
Label5.Caption := Format('%.4d', [2]);
end;

[babak_delphi]

یک کامپوننت به همراه نمونه کد قرار میدم
از روی نمونه کد ، خودتون می تونید برنامه مورد نظرتون رو بنویسید

[babak_delphi]

جایی یک نمونه برنامه خیلی ساده دیدم که به فرم ، یک افکت ساده داده بود
آپلود می کنم
شاید مفید واقع بشه

[babak_delphi]

مورد توجه کسانی که می خواهند با کد نویسی با پورت com ارتباط برقرار کنند

میتونید اونا رو مثل یک فایل باز کنید و توشون بنویسید یا ازشون بخونید

این کد باز کردن پورت


procedure TMainForm.OpenPort(i:Integer);
{}
Procedure InitSerial;
Var
DCB: TDCB;
Config : String;
CommTimeouts : TCommTimeouts;
begin
if not SetupComm(hCom, RxBufferSize, TxBufferSize) then
showMessage('CanNot Setup Com Port');
if not GetCommState(hCom, DCB) then
showmessage('can not read com state')
Else
Begin
Config :=Pchar('baud=19200 parity=n data=8 stop=1'+#0);
if not BuildCommDCB(@Config[1], DCB) then
ShowMessage('Can Not build com dcb')
else
if not SetCommState(hCom, DCB) then
ShowMessage('Can Not set com state');
End;
with CommTimeouts do
begin
ReadIntervalTimeout := 0;
ReadTotalTimeoutMultiplier := 0;
ReadTotalTimeoutConstant := 1000;
WriteTotalTimeoutMultiplier := 0;
WriteTotalTimeoutConstant := 1000;
end;
if not SetCommTimeouts(hCom, CommTimeouts) then
showMessage('Can not set com timeout');
End;
begin
CPN:=i; //initialize serial Port to Boud=9600 Parity=none startbit=1
hCom := CreateFile(PChar(ComPort),
Generic_Read,// Or GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hCom = INVALID_HANDLE_VALUE then
showMessage('Error Opening File')
else
Begin
InitSerial;
End;
end;



اینهم کد خواندن



function TMainForm.read1byteFromPort:byte;
Var
d: array[1..1] of byte;
s: String;
BytesRead, i: cardinal;
Begin
if not ReadFile (hCom, d, sizeof(d), BytesRead, Nil) then
read1byteFromPort:=0
Else
read1byteFromPort:=d[1];
end;



موفق باشید.

[babak_delphi]

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


چون به این تاپیک هم مربوط میشد دوباره در اینجا نمی نویسم اما لینکش را در اینجا قرار میدهم

http://barnamenevis.org/forum/showthread.php?t=103358

امیدوارم مفید واقع شود

[Vahid_moghaddam]

وقتی از یک DBGrid برای نمایش اطلاعات یک DataSet مثل query یا table استفاده می کنیم، بعد از Refresh شدن dataset مثلا بسته و باز شدنش، موقعیت جاری سطر روی صفر یعنی اولین رکورد تنظیم می شود. تصور کنید کاربر جایی در انتهای DBGrid باشد!
در کد زیر، Refresh در dataset با حفظ موقعیت سطر انجام می شود. در این کد کلاسی به نام THACKDBGrid تعریف شده است. با این کلاس می توان به خاصیتهای protected کلاس TDBGrid دسترسی داشت (نکته جالب!).




//THackDBGrid = class(TDBGrid)


procedure Refresh_PreservePosition;
var
rowDelta: Integer;
row: integer;
recNo: integer;
ds : TDataSet;
begin
ds := THackDBGrid(DBGrid1).DataSource.DataSet;


rowDelta := -1 + THackDBGrid(DBGrid1).Row;
row := ds.RecNo;


ds.Refresh;


with ds do
begin
DisableControls;
RecNo := row;
MoveBy(-rowDelta) ;
MoveBy(rowDelta) ;
EnableControls;
end;
end;

[سعید صابری]

سلام چگونه ميشه شماره سريال سي دي را بدست آورد
خود سي دي نه سي دي رام

[hector2000]

ایا دلفی 2007 پروژه هاش را unicode می تواند ذخیره کند که مشکل فارسی نداشته باشیم؟

[babak_delphi]

var
pt:tpoint
begin
getcursorpos(pt);
label1.caption:= 'X : '+inttostr(pt.x)+' , Y :'+inttostr(pt.y);
end

[babak_delphi]

function SetFileReadOnly (FileName: String; ReadOnly: Boolean = True): Boolean;
begin
if not FileExists (FileName) then
Result := False
else
begin
if ReadOnly then
Result := SetFileAttributes (PChar (FileName), GetFileAttributes (PChar (FileName)) or FILE_ATTRIBUTE_READONLY)
else
Result := SetFileAttributes (PChar (FileName), FILE_ATTRIBUTE_NORMAL);
end;
end;

[babak_delphi]

فرض کنید میخواهیم در پروژه خود کاربر بتواند بدون تغییر صفحه کلید (Alt + Shift)در برخی Edit ها امکان تایپ فارسی را داشته باشد

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

۱) معرفی زبان فارسی به پروژه

ابتدا کد اصلی پروژه را باز کنید واین خط رابعد از خط Application.Initialize اضافه کنید یا در OnShow فرم اصلی این کد را بنویسید.

Application.BiDiKeyboard:='00000429';

۲) تنظیم خاصیت BiDimode به حالت bdRightToLeft برای هر Edit مورد نظر

حال پروژه را اجرا کنید.

البته بجای Application.BiDiKeyboard:='00000429' میتوانید از کد زیر هم استفاده کنید :
LoadKeyboardLayout(PChar('00000429'), KLF_ACTIVATE)

[AlirezaBahredar]

سلام چگونه ميشه شماره سريال سي دي را بدست آورد
خود سي دي نه سي دي رام

یک روشی که من استفاده کردم برای این موضوع به اینصورت بود که در CMD دستور زیر را اجرا می کنم
: Dir F با این روش سطر دوم شماره سریال CD رو بدست میاری....
موفق باش.....

[saleh_fartash]

برای شما آموزش ساخت سرویس رو می ذارم ( سرویس توسط ویندوز چک میشه و حتی در وضعیت
log of هم به شما خبر می ده)
ساخت سرویسی که ServiceApplication يسازم که هر 10 ثانيه يه پيغام رو نشون بدهد:

براي نوشتن يک Service Application که بتواند هر 10 ثانيه يک پيغام نشان دهد:
ابتدا از منوي file گزينه New را انتخاب کرده و سپس روي گزينه Other کليک کنيد بعد در پنجره باز شده از سربرگ New گزينه ServiceApplication را انتخاب کنيد. با انجام اين کار يک کلاس با نام TService1 ايجاد مي شود که مي توانيد با قرار دادن هر شيء مورد دلخواه بر روي فرم آن برنامه خود را بنويسيد. براي برنامه ما از سربرگ System يک Timer بر روي سرويس گذاشته و خاصيت Interval آن را 10000 بگذاريد. حال در رويداد OnTimer کد زير را بنويسيد:
Showmessage('My Service is worked currently');
خاصيت DisplayName مربوط به Service1 را به MyTstSrv تغيير دهيد. اين نام بعد از اجراي سرويس در ليست سرويسها ظاهر مي شود.
خاصيت Interactive مربوط به Service1 را به True تغيير دهيد.
در رويداد OnExecute مربوط به Service1 کد زير را بنويسيد:
while not Terminated do
ServiceThread.ProcessRequests(True);// wait for termination
حال موقع نصب سرويس بر روي ويندوز رسيده است. براي اينکار بايد برنامه را با پارامتر/install اجرا کنيد. پس در دلفي به منوي Run رفته و روي گزينه Parameters کليک کنيد. در اين پنجره در کادر مربوط به Parameters عبارت /install را تايپ کنيد و روي Ok کليک کنيد. حال برنامه را اجرا کنيد. اگر همه مراحل را بدرستي انجام داده باشيد پيغام Service installed successfully ظاهر مي شود.
حال بايد به ليست سرويسهاي ويندوز برويد و سرويس خود را Start کنيد. (اين سرويس مي تواند با restart شدن ويندوز نيز Start شود) براي اين کار به Control Panel رفته و پنجره Administrative Tools را باز کنيد. در اين پنجره روي گزينه Services دابل کليک کنيد. با انجام اين کار يک پنجره باز مي شود که نام تمامي سريسهاي نصب شده برروي ويندوز وجود دارند. نام MyTstSrv را پيدا کرده و روي آن کليک راست کنيد و سپس گزينه Start را انتخاب کنيد. با انجام اين کار سرويس شما Start شده و بايد هر 10 ثانيه يکبار پيام شمار را نمايش دهد.
براي حذف کردن سرويس از روي ويندوز بايد برنامه را با پارامتر /Uninstall اجرا کنيد. با انجام اين کار پيام Service Uninstalled Successfully ظاهر مي شود.

( باید بگم که"/" قبل از install , uninstall است)

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

winexec(Service_address.exe+' /install',sw_Show);

همچنین برای حذف سرویس از دستور زیر

winexec(Service_address.exe+' /uninstall',sw_Show);

یا میتونی از توی cmd این دو کد را برای نصب و حذف سرویس بنویسی

service_address.exe /install
service_address.exe /uninstall

[babak_delphi]

کدی برای پاک کردن Edit ها , DBEdit ها MaskEdit ها و Memo های یک فرم :



procedure clear_all;
var
cnt : integer;
begin
Try
for cnt := 0 to Screen.ActiveForm.ComponentCount - 1 do
begin
if (Screen.ActiveForm.Components[cnt].ClassName = 'TEdit')
AND (TEdit(Screen.ActiveForm.Components[cnt]).Tag = 0 ) then
TEdit(Screen.ActiveForm.Components[cnt]).Clear
else if (Screen.ActiveForm.Components[cnt].ClassName = 'TMaskEdit') then
TMaskEdit(Screen.ActiveForm.Components[cnt]).Clear
else if (Screen.ActiveForm.Components[cnt].ClassName = 'TDBEdit')
AND (TDBEdit(Screen.ActiveForm.Components[cnt]).Tag = 0 ) then
TDBEdit(Screen.ActiveForm.Components[cnt]).Clear
else if (Screen.ActiveForm.Components[cnt].ClassName = 'TDBMemo') then
TDBMemo(Screen.ActiveForm.Components[cnt]).Clear;
end;
Except
// show error message
end;
end;


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

[SUNMOON]

چرا وقتي ت صفحه اول اين تاپيك رو هر كدوم از لينك ها كليك مي كنم همشون يه صفحه رو باز مي كنن؟

[vcldeveloper]

چرا وقتي ت صفحه اول اين تاپيك رو هر كدوم از لينك ها كليك مي كنم همشون يه صفحه رو باز مي كنن؟
ظاهرا مشکلی در نرم افزار سایت هست. البته مشکل جدیدی نیست، مدتهاست که این مشکل وجود داره.

[Mah6447]

این کد در حقیقت برای رفتن به تب بعدی روی فرم است.


procedure Go_Next_Tab(Key : Char);
begin
Try
if (Key = #13) then
begin
PostMessage(Screen.ActiveForm.Handle, WM_NEXTDLGCTL, 0, 0);
Key := #0;
end;
Except
Application.MessageBox(' !!! یک اشکال ناشناخته در روند انجام کار پیش آمده است ','ERROR',MB_OK + MB_ICONERROR);
end;
end;


مي توانيد مثالي بياوريد

[Mah6447]

خواندن Version Info یک فایل


function GetVersion: string;
var
VerInfoSize: DWORD;
VerInfo: Pointer;
VerValueSize: DWORD;
VerValue: PVSFixedFileInfo;
Dummy: DWORD;
begin
Result := '';
VerInfoSize := GetFileVersionInfoSize(PChar(ParamStr(0)), Dummy);
if VerInfoSize = 0 then Exit;
GetMem(VerInfo, VerInfoSize);
GetFileVersionInfo(PChar(ParamStr(0)), 0, VerInfoSize, VerInfo);
VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
with VerValue^ do
begin
Result := IntToStr(dwFileVersionMS shr 16);
Result := Result + '.' + IntToStr(dwFileVersionMS and $FFFF);
Result := Result + '.' + IntToStr(dwFileVersionLS shr 16);
Result := Result + '.' + IntToStr(dwFileVersionLS and $FFFF);
end;
FreeMem(VerInfo, VerInfoSize);
end;




جناب آقاي مهران مي توان نسخه مكافي نصب شده در سيستم را با اين روش بدست آورد ممنون مي شوم
اگر ممكن است با مثال بيان نماييد

[mohsen_solhjoo]

سلام
چطور می تونم از مسیر دایرکتوری که هستم یک level بالاتر رو ببینم

[s.mostafa.rahmani]

تبدیل RGB به CMYK (http://barnamenevis.org/forum/showpost.php?p=45450&postcount=172)
اين كه يه مطلب ديگه رو باز مي‌كنه :(

[s.mostafa.rahmani]

سلام
حتماً اتفاق افتاده كه موقع طراحي و استفاده از كد رنگها مجبور شدين كد دسيمال رنگهاي RGB رو به هگز يا برعكسش (از هگز به دسيمال) تبديل كنيد.
اين برنامه اين كار رو براي شما ساده كرده:

اين هم لينك برنامه: http://www.box.net/shared/8khbb35sht

اين هم لينك سورسش: http://www.box.net/shared/do719djogl

.

[babak_delphi]

مي توانيد مثالي بياوريد
3 تا edit بذارید روی فرم و TabOrder اونها رو تنظیم کنید
بعد این تابع رو همانطور که در همین بخش توضیح دادم بنویسید و استفاده کنید
این کد رو باید در Onkeypress بنویسید

[saleh_fartash]

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

[NIUSHA_KH]

با تشکر فراوان
لینکهای آخر فهرست ، اشتباها همه به تغییر ولیوم اشاره میکند