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

[vcldeveloper]

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

[lolojoon]

کد بستن Alt + F4 :




if (key =VK_F4 ) And ( ssAlt in shift ) then Key:=0





کد On Top کردن فرم :



procedure TForm1.FormShow(Sender: TObject);

begin

SetWindowPos(Form1.Handle,HWND_TOPMOST,

0, 0, 0, 0,

SWP_NOMOVE or SWP_NOSIZE or SWP_SHOWWINDOW);



end;

[Mah6447]

جناب آقای babak_delphi دست شما درد نکند تست زدم درست کار می کند
حال آیا می توان با استفاده از کلیک های Up , Down و با توجه به Taborder های تعریف شده
حرکت کرد (راهی شبیه به راه عنوان شده)
با تشکر

[dornasho]

Uses ..., axctrls;

procedure TForm1.Open1Click(Sender: TObject);
var
f : TFileStream;
graphic : TOleGraphic;
begin
if OpenDialog1.Execute then
begin
graphic := TOleGraphic.Create;
f := TFileStream.Create (OpenDialog1.FileName,
fmOpenRead or fmShareDenyNone);
try
graphic.LoadFromStream(f);
Image1.Picture.Assign(graphic);
finally
f.Free
end
end
end;

[dornasho]

تبدیل اشیاء موجود در فرم به تصویر

توضیح با یک مثال:

یک استرینق گراید در فرم داریم می خواهیم تصویری از محتویاتش در فرم داشته باشیم:


uses clipbrd;


procedure TForm1.Button1Click(Sender: TObject);
var
CopiaGRID : TBitmap;
begin
CopiaGRID := TBitmap.Create;
CopiaGRID.Width := StringGrid1.Width;
CopiaGRID.Height := StringGrid1.Height ;
StringGrid1.PaintTo (CopiaGRID.Canvas.Handle, 0, 0);
clipboard.assign(CopiaGRID);
CopiaGRID.Destroy;
end;

حالا تصویر استرینق گراید ما در کلیپ برد موجود است و با دستور زیر در یک Timag لود می کنیم:

procedure TForm1.Button2Click(Sender: TObject);
var
bmp: TBitmap;
begin
if Clipboard.HasFormat(CF_PICTURE) then
begin
bmp := TBitmap.Create;
try
bmp.Assign(Clipboard);
Image1.Picture.Bitmap.Assign(bmp);
except
// Can't convert
end;
bmp.Free;
end else
begin
ShowMessage('تصويري در حافظه مو جود نيست');
end;
end;

[dornasho]

توضیح با مثال:

یک استرینق گراید در فرم داریم می خواهیم تصویری از محتویاتش در یک TImage داشته باشیم:

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


uses clipbrd;

procedure TForm1.Button1Click(Sender: TObject);
var
CopiaGRID : TBitmap;
begin
CopiaGRID := TBitmap.Create;
CopiaGRID.Width := StringGrid1.Width;
CopiaGRID.Height := StringGrid1.Height ;
StringGrid1.PaintTo (CopiaGRID.Canvas.Handle, 0, 0);
clipboard.assign(CopiaGRID);
CopiaGRID.Destroy;
end;


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


procedure TForm1.Button2Click(Sender: TObject);
var
bmp: TBitmap;
begin
if Clipboard.HasFormat(CF_PICTURE) then
begin
bmp := TBitmap.Create;
try
bmp.Assign(Clipboard);
Image1.Picture.Bitmap.Assign(bmp);
except
// Can't convert
end;
bmp.Free;
end else
begin
ShowMessage('تصويري در حافظه مو جود نيست');
end;
end;

[مائده 100]

با سلام و عرض خیر مقدم خدمت برنامه نویسان و برنامه نویسان بعد از این :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)
ما هر قسمتی را روش کلیک می کنیم فقط بخش تغییر vllow سیستم را می آره

[vcldeveloper]

ما هر قسمتی را روش کلیک می کنیم فقط بخش تغییر vllow سیستم را می آره
در پست شماره 252 یک بار توضیح دادم.

[lord_viper]

کسانی که از بانک اطلاعاطی پارادوکس استفاده ميکنن برای جلوگيری از تخريب فايل و حذف فيزيکی رکوردها از جداول اطلاعاتی هرچند وقت يکبار اقدامبه فشرده کردن جدول کنند تابع زير که به paradoxpack موسوم است جهت فشرده كردن جداول پارادوكس ارائه ميشود
يونيتDBIPROCS را به قسمت uses اضافه کنید



procedure TForm1.ParadoxPack(Tabela: TTable);

var TBDesc: CRTblDesc;

hDb: hDbiDb;

CaminhoTabela: array[0..dbiMaxPathLen] of char;

begin

If not Tabela.Active then

Tabela.Open;

FillChar(TBDesc,Sizeof(TBDesc),0);

With TBDesc do begin

StrPCopy(szTblName,Tabela.TableName);

StrPCopy(szTblType,szParadox);

bPack:=True;

end;

hDb:=nil;

Check(DbiGetDirectory(Tabela.DBHandle,True,Caminho Tabela));

Tabela.Close;

Check(DbiOpenDatabase(nil,'STANDARD',dbiReadWrite, dbiOpenExcl,nil,0,nil,nil,hDb) );

Check(DbiSetDirectory(hDb,CaminhoTabela));

Check(DBIDoRestructure(hDb,1,@TBDesc,nil,nil,nil,F alse));

Tabela.Open;

end;


procedure TForm1.Button1Click(Sender: TObject);

begin

ParadoxPack(Table1);

end;

[lord_viper]

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


uses
ComObj;

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

[دکمه64]

کدی برای تست روشن بودن چراغ های سه گانه


public
procedure CheckCapslock;
procedure CheckNumlock;
procedure CheckInslock;
procedure CheckScrlock;
{ public declarations }
end;
procedure TForm1.CheckCapslock;
begin
if Odd (GetKeyState (VK_CAPITAL)) then
StatusBar1.Panels[1].Text := 'Caps'
else
StatusBar1.Panels[1].Text := '';
end;
procedure TForm1.CheckNumlock;
begin
if Odd (GetKeyState (VK_NUMLOCK)) then
StatusBar1.Panels[2].Text := 'Num'
else
StatusBar1.Panels[2].Text := '';
end;
procedure TForm1.CheckInslock;
begin
if Odd (GetKeyState (VK_INSERT)) then
StatusBar1.Panels[3].Text := 'Ins'
else
StatusBar1.Panels[3].Text := '';
end;
procedure TForm1.CheckScrlock;
begin
if Odd (GetKeyState (VK_SCROLL)) then
StatusBar1.Panels[4].Text := 'Scr'
else
StatusBar1.Panels[4].Text := '';
end;
procedure TForm1. Timer1Timer(Sender: TObject);
begin
CheckCapslock;
end;
procedure TForm1. Timer2Timer(Sender: TObject);
begin
CheckNumlock;
end;
procedure TForm1. Timer3Timer(Sender: TObject);
begin
CheckInslock;
end;
procedure TForm1. Timer4Timer(Sender: TObject);
begin
CheckScrlock;
end;

[دکمه64]

کدی برای بزرگ کردن حرف اول در ادیت باکس ها
[
CODE]
procedure TForm1.DBEdit1Change(Sender: TObject);
var

Cursor : Integer;
begin
if DBEdit1.Text <> '' then
begin
Cursor:=DBEdit1.SelStart;
DBEdit1.Text := UpperCase(Copy(DBEdit1.Text,1,1)) +
LowerCase(Copy(DBEdit1.Text,2,Length(DBEdit1.Text) ));
DBEdit1.SelStart := Cursor;
end;
end;



[/CODE]

[alireza71]

سلام
ببخشيد ميخواستم بدونم چه طوري ميشه فونت را به فايل اجرايي(exe) در دلفي اضافه كنيم.
email:alireza2756@gmail.com

[negarin5340]

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

[دکمه64]

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

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

[negarin5340]

سلام مجدد
برنامه من برای یه شرکته که تمام حساب های دفتری اونها رو می خوام به برنامه تبدیل کنم این برنامه کارهای زیر رو اجام میده :
1- ثبت کردن اطلاعات
2 - ویرایش اطلاعات
3- حذف اطلاعات
و جستجو که این برنامه چون برای یه مرکز ISP است بطور مثال با وارد کردن شماره تلفن اطلاعات خواسته شده رو نمایش دهد
مشکل من حالا اینه اون اطلاعات مربوط به یک نفر رو که ذخیره می کنم باید باشه که بتونم کارهای دیگگگه رو انجام بدم نه اینکه هر روز صبح کاربر اطلاعات رو دوباره ذخیره کنه چون می خواهیم با این برنامه حساب های دفتری رو ببندیم تو رو خدا کمکم کنید

[دکمه64]

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

[negarin5340]

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

[دکمه64]

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

عناصر:
1) ADOTable1 از صفحه ADO
2) DBGrid1
3) DataSource1

خاصیت dataset عنصر DataSource1 را ADOTable1 انتخاب کنید
خاصیت DataSource عنصر DBGrid1 را DataSource1 انتخاب کنید
خاصیت ConnectionString عنصر ADOTable1 را کلیک کرده گزینه Use ConnectionString را انتخاب و دکمه build را کلیک کنید در صفحه بعد گزینه Microsoft.Jet.OLEDB.4.0 را انتخاب و دکمه next را کلیک کنید در صفحه Connection مسیر فایل اکسس ذخیره شده را انتخاب و دکمه ok را کلیک کنید.
حال خاصیت Tablename عنصر ADOTable1 را جدول مورد نظر ساخته شده در فایل اکسس انتخاب کنید و در آخر خاصیت active عنصر ADOTable1 را true کنید
بیشتر دستوراتی که باید با عنصر ADOTable استفاده کنید همانند عنصر Table هست.
موفق باشید.

[دکمه64]

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

عناصر:
1) ADOTable1 از صفحه ADO
2) DBGrid1
3) DataSource1

خاصیت dataset عنصر DataSource1 را ADOTable1 انتخاب کنید
خاصیت DataSource عنصر DBGrid1 را DataSource1 انتخاب کنید
خاصیت ConnectionString عنصر ADOTable1 را کلیک کرده گزینه Use ConnectionString را انتخاب و دکمه build را کلیک کنید در صفحه بعد گزینه Microsoft.Jet.OLEDB.4.0 را انتخاب و دکمه next را کلیک کنید در صفحه Connection مسیر فایل اکسس ذخیره شده را انتخاب و دکمه ok را کلیک کنید.
حال خاصیت Tablename عنصر ADOTable1 را جدول مورد نظر ساخته شده در فایل اکسس انتخاب کنید و در آخر خاصیت active عنصر ADOTable1 را true کنید
بیشتر دستوراتی که باید با عنصرADOTable استفاده کنید همانند عنصرTable هست.
موفق باشید.

[Pr0grammer]

یه برنامه شبیه Magnifier ویندوز

[Akam Zandi]

باسلام وتشکّر:
من روی هر لینکی که کلیک می کنم اون لینک باز نمی شه؟

[hashem_te]

با سلام
اكثر لينكهاي فوق اشتباها به "تغییر Volume ویندوز" منتهي ميشوند
من با لينك "غير فعال كردن دگمه Close در فرم" كار داشتم ولي كليك روي آن صفحه "تغییر Volume ویندوز" را باز ميكند

در صورت امكان اصلاح نماييد
با تشكر
هاشمي
hashemi-te@esfahansteel.com

[دکمه64]

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


ProgressBar1: TprogressBar;

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

var
ProgressBarStyle: LongInt;
begin
{create a run progress bar in the status bar}
ProgressBar1 := TProgressBar.Create(StatusBar1);
ProgressBar1.Parent := StatusBar1;
{remove progress bar border}
ProgressBarStyle := GetWindowLong(ProgressBar1.Handle, GWL_EXSTYLE);
ProgressBarStyle := ProgressBarStyle - WS_EX_STATICEDGE;
SetWindowLong(ProgressBar1.Handle, GWL_EXSTYLE, ProgressBarStyle);
{set progress bar position and size - put in Panel[2]}
ProgressBar1.Left := StatusBar1.Panels.Items[0].Width +
StatusBar1.Panels.Items[1].Width + 4;
ProgressBar1.Top := 4;
ProgressBar1.Height := StatusBar1.Height - 6;
ProgressBar1.Width := StatusBar1.Panels.Items[2].Width - 6;
{set range and initial state}
ProgressBar1.Min := 0;
ProgressBar1.Max := 100;
ProgressBar1.Step := 1;
ProgressBar1.Position := 0;
end;



حالا برای آنکه پس از خارج شدن از فرم حافظه اشغال شده آزاد گردد، در قسمت OnDestroy در Event فرمتان دستور زیر را اضافه نمایید:
ProgressBar1.free;

[دکمه64]

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

ابتدا باید یک عنصر جدید مبتنی بر TDBGrid ایجاد کنید و رویداد OnMouseMove را فراخوانی کنید:

type
TMyDBGrid = class(TDBGrid)
published
property OnMouseMove;
end;


اگرچه شما در رویداد OnMouseMove مختصات X و Y را بدست خواهید آورد، اما شما باید ستون مورد نظر را پیدا کنید. برای ادامه کار لازم است که سطر زیر را در قسمت protected قرار دهید:

procedure WMMouseMove(var Message : TWMMouse); message WM_MOUSEMOVE;

همچنین متغیر های زیر را در قسمت public اضافه نمایید:

MouseRow : integer;
MouseCol : integer;

بنابراین متد WMMouseMove بصورت ریر خواهد بود:

procedure TMyDBGrid.WMMouseMove(var Message : TWMMouse);
var
t : TGridCoord;
begin
t := MouseCoord(Message.XPos, Message.YPos);
MouseCol := t.x;
MouseRow := t.y;
inherited;
end;


ما ابتدا فیلدهای XPost و YPos را از ساختار WMMouseMove تنظیم میکنیم:

procedure TForm2.MyDBGrid1MouseMove(Sender: TObject; Shift: TShiftState; X, Y:
Integer);
begin
if (((dgIndicator in MyDBGrid1.Options) and (MyDBGrid1.MouseCol > 0)) or
((not (dgIndicator in MyDBGrid1.Options)) and (MyDBGrid1.MouseCol <> -1)))
and (MyDBGrid1.MouseCol <> OldMouseCol) then begin
OldMouseCol := MyDBGrid1.MouseCol;
if dgIndicator in MyDBGrid1.Options then
MYDBGrid1.Hint := MyDBGrid1.Columns[MyDBGrid1.MouseCol - 1].FieldName
else
MYDBGrid1.Hint := MyDBGrid1.Columns[MyDBGrid1.MouseCol].FieldName;
end;
end;



حالا مجددا" تعریف زیر را در قسمت public قرار دهید:

HintMouseMessage(Control : TControl; var Message : TMessage)

در قسمت OnMouseMove از TDBGrid نیز فرامین زیر را اضافه نمایید:

var
r : TMessage;
begin

Application.HintMouseMessage(self, r);
TWMMouse(r).XPos := X;
TWMMouse(r).YPos := Y;
Application.HintMouseMessage(MyDBGrid1, r);
end;

[دکمه64]

نمایش میزان كپی شدن فایل با ProgressBar در دلفی

چطور میتوان زمان کپی شدن فایل را با استفاده از ProgressBar نمایش داد؟
برای انجام این کار ابتدا بر روی یک فرم یک ProgressBar اضافه کنید سپس تابع زیر را تایپ کنید:

procedure TForm1.CopyFileWithProgressBar1(Source, Destination: string);
var
FromF, ToF: file of byte;
Buffer: array[0..4096] of char;
NumRead: integer;
FileLength: longint;
begin
AssignFile(FromF, Source);
reset(FromF);
AssignFile(ToF, Destination);
rewrite(ToF);
FileLength := FileSize(FromF);
with Progressbar1 do
begin
Min := 0;
Max := FileLength;
while FileLength > 0 do
begin
BlockRead(FromF, Buffer[0], SizeOf(Buffer), NumRead);
FileLength := FileLength - NumRead;
BlockWrite(ToF, Buffer[0], NumRead);
Position := Position + NumRead;
end;
CloseFile(FromF);
CloseFile(ToF);
end;
end;


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

procedure TForm1.Button1Click(Sender: TObject);
begin
CopyFileWithProgressBar1('c:\Welcome.exe', 'c:\temp\Welcome.exe');
end;



چطور می توان زمان کپی شدن فایل را محاسبه و نمایش داد؟
برای این کار نیز میتوانید از تابع زیر استفاده کنید:

procedure TForm1.CopyFileWithProgressBar1(Source, Destination: string);
var
FromF, ToF: file of byte;
Buffer: array[0..4096] of char;
NumRead: integer;
FileLength: longint;
t1, t2: DWORD;
maxi: integer;
begin
AssignFile(FromF, Source);
reset(FromF);
AssignFile(ToF, Destination);
rewrite(ToF);
FileLength := FileSize(FromF);
with Progressbar1 do
begin
Min := 0;
Max := FileLength;
t1 := TimeGetTime;
maxi := Max div 4096;
while FileLength > 0 do
begin
BlockRead(FromF, Buffer[0], SizeOf(Buffer), NumRead);
FileLength := FileLength - NumRead;
BlockWrite(ToF, Buffer[0], NumRead);
t2 := TimeGetTime;
Min := Min + 1;
// Show the time in Label1
label1.Caption := FormatFloat('0.00', ((t2 - t1) / min * maxi - t2 + t1) / 100);
Application.ProcessMessages;
Position := Position + NumRead;
end;
CloseFile(FromF);
CloseFile(ToF);
end;
end;


در این تابغ ابتدا زمان اولیه در متغیر t1 ذخیره شده و سپس پس از کپی شدن هر قسمت از فایل، زمان در متغیر t2 ذخیره میشود و توسط فرمول زیر مقدار زمان باقی مانده تا کپی کامل فایل بدست می آید.


((t2 - t1) / min * maxi - t2 + t1) / 100

[hadiaj168]

بازی حدس زدن عدد.مثبت یعنی عدد و مکانش درسته،منفی یعنی فقط عدد درسته و جاش غلطه!

[Naruto]

من با لينك "غير فعال كردن دگمه Close در فرم" كار داشتم ولي كليك روي آن صفحه "تغییر Volume ویندوز" را باز ميكند


سلام.
غیرفعال کردن دکمه Close در SystemMenu :



Var
hMenuHandle: Integer;
Begin
hMenuHandle := GetSystemMenu(Handle, False);
if (hMenuHandle <> 0) then
DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
End;


فعال کردن دکمه Close در SystemMenu :



Var
hMenuHandle:Integer;
Begin
hMenuHandle := GetSystemMenu(Handle, True);
if (hMenuHandle <> 0) then
EnableMenuItem(hMenuHandle,SC_CLOSE,MF_BYCOMMAND OR MF_ENABLED);
End;

[hadiaj168]

یه برنامه برای محاسبه هزینه تلفن و اینترنت یه چیزی شبیه DialSpy البته در اندازه های کوچیکتر:لبخندساده:
ممنون میشم اگه نظر بدین واشکالاتم رو بگید.
البته بیشترش حاصل کد ها و راه نمایی های خودتونه!
یک قسمت دیگه به برنا مه اضافه کردم که به صورت خودکار پروسه های مورد نظر رو اجرا یا متوقف کنه.
من خودم عادت دارم وقتی به اینترنت وصل میشم آنتی ویروس رو راه اندازی میکنم و پس از قطع ارتباط میبندمش قسمت اظافه شده این کار رو انجام میده.(آخر تن پروری:لبخند:!)
و برخی برنامه ها هم در هنگام اتصال باید بسته باشن تا تقلبی بودن شون توسط سرور معلوم نشه و از کار نیفتن مثل مجموعه CS4.
(سه فایل زیپ 1و2و3 را داخل یک پوشه خالی کنید)

[Yasersadegh]

در رويداد FormCreate ابتدا يك متغير تعريف مي كنيم :



var h: THandle;

سپس با استفاده از كد زير ابتدا يك بيضي ساخته و سپس فرم را به شكل اين بيضي در مي آوريم:




h := CreateEllipticRgn(40,40,300,200);
SetWindowRgn(form1.Handle,h,TRUE);

[Yasersadegh]

در دلفي مي توان با استفاده از متد Show يك فرم را نمايش داد.
در اين قسمت مي خواهيم كه در صورت صحيح بودن يك شرط از نمايش فرم جلوگيري شود.
براي اين كار، با توجه به اينكه با فراخواني متد Show در فرم اول ، رويداد Onshow از فرم دوم اجرا مي شود. بايد از كد زير در اين رويداد(يعني رويداد onShow فرم دوم) استفاده كنيم :



if Form1.Edit1.Text=IntToStr(1) then
PostMessage(form2.Handle,WM_CLOSE,0,0);



دستور PostMessage با پارامتر WM_CLOSE باعث عدم نمايش فرم مي شود. در كد بالا در صورتي كه مقدار Edit1 برابر با 1 شود، Form2 نمايش داده نمي شود.

[MOJTABAATEFEH]

آقاي mzjahromi مطلب پست 127 روي عبارات IsPublishedProp و GetOrdProp و SetOrdProp خطا ميده و ناشناس تشخيص داده مي شوند لطفا رسيدگي كنيد

با تشكر

[MOJTABAATEFEH]

با این کد می توانید عنوان دکمه برنامه خودتون رو در Taskbar متحرک کنید :



procedure TForm1.Timer1Timer(Sender: TObject);
const
{$J+}
animatedTitle : string = 'www.mojtabaie.persianblog.ir';
{$J-}
var
cnt: Integer;

begin
Application.Title := animatedTitle;
for cnt := 1 to (Length(animatedTitle) - 1) do
begin
animatedTitle[cnt] := Application.Title[cnt + 1];
animatedTitle[Length(animatedTitle)] := Application.Title[1];
end;
end;

منبع : http://delphi.about.com (http://www.delphi.about.com)
www.mojtabaie.persianblog.ir (http://www.mojtabaie.persianblog.ir)
(http://delphi.about.com/)

[MOJTABAATEFEH]

بدست آوردن Event های یکComponent :


uses


TypInfo;

...
procedure TForm1.Button1Click(Sender: TObject);
var
ListProp: PPropList;
TD: PTypeData;
Num, i: Integer;
begin
GetMem(ListProp, SizeOf(PPropInfo)*TD.PropCount);
Num:=GetPropList(
Sender.ClassInfo,
[tkMethod],
ListProp);
for i:=0 to Num-1 do
Memo1.Lines.Add(ListProp[i]^.Name);
end;

شما می توانید بجای Sender که با رنگ قرمز مشخص شده نام کامپوننت مورد نظر را بنویسید

[Naruto]

سلام دوستان.

دستور زیر به شما نشون میده که چطور تو رجیستری یه مقدار Multi-String درست کنید و چندخط توش بنویسید.




procedure TForm1.FormCreate(Sender: TObject);
Var
Reg : TRegistry;
begin
With Reg do
Begin
RootKey:= HKEY_LOCAL_MACHINE;
OpenKey('SYSTEM\CurrentControlSet\Services\Naruto' , False);
RegSetValueEx(CurrentKey,'ValueName',0,REG_MULTI_S Z,
PWideChar('YouString1'+#0+'YourString2'+#0),
Length('YourSting1'+#0+'YourString2'+#0)*2);
End;
End;

[hadiaj168]

یک لیست (http://www.dswag.com/modules.php?op=modload&name=FAQ&file=index&myfaq=yes&id_cat=9&categories=WINDOWS+API&parent_id=0#89) از توابع WINDOWS API
· Determine the last access time of a given file
· Using the Shell API function SHBrowseForFolder()
· Detecting if the system time has been changed
· Trapping for when a user is done resizing a window
· Using the WIN API high resolution performance counter
· Getting modem status under Win32
· adding system menu items to a form
· Clearing the recent Documents from the Start Menu
· Copying files using the Standard Windows Copy file dialog box
· Creating a custom word break procedure
· How can I get serial number of my drive
· Determining Drive Type
· Using FindFirst to search for files.
· Getting an handle to a window in another application.
· Checking drive ready status.
· External function failure when passing boolean parms.
و....

[Felony]

سلام

برنامه اتصال به اینترنت به صورت خودکار در ساعت مشخص.
ویژگی ها و تنظیمات:

1-تنظیم زمان اتصال.
2-تنظیم زمان قطع ارتباط .
3-خاموش شدن سیستم پس از قطع اتباط .
4-اجرای نرم افزار مدیریت دانلود .
5-خاموش شدن سیستم پس از سه بار خطا در برقراری ارتباط .
6-قرارگرفتن در startup .

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

امید وارم مفید واقع بشه...

[جناب کشاورز اگه دو دقیقه صبر میکردید محتواش هم میومد. بلا نسبت ... نیستم که ساعت 2 نصفه شب بشینم الکی تایپ کنم:عصبانی:]
:گریه:جای این مطلب به نظرت تو بخش پروژه های متن باز یا حداقل تاپیک جداگانه نبود ؟

[zidane]

اگر شما هم مثل من حالتون از http://contest2004.thinkquest.jp/tqj2004/70619/dic/dicmateria/crHandPoint.png(crHandPoint) به هم می خوره و می خواهید از شکل استاندارد ویندوز (http://telcontar.net/Misc/screeniecursors/Cursor%20hand%20white.png) استفاده کنید، کافیه در رویداد FormCreate خط زیر رو اضافه کنید تا crHandPoint به شکل استاندارد ویندوز تغییر کنه:

Screen.Cursors[crHandPoint] := LoadCursor(0, IDC_HAND);

[Majid.Ebru]

اگر شما هم مثل من حالتون از http://contest2004.thinkquest.jp/tqj2004/70619/dic/dicmateria/crHandPoint.png(crHandPoint) به هم می خوره و می خواهید از شکل استاندارد ویندوز (http://telcontar.net/Misc/screeniecursors/Cursor%20hand%20white.png) استفاده کنید، کافیه در رویداد FormCreate خط زیر رو اضافه کنید تا crHandPoint به شکل استاندارد ویندوز تغییر کنه:

Screen.Cursors[crHandPoint] := LoadCursor(0, IDC_HAND);

سلام
آقا این کد کار نکرد میشه راهنمایی کنید؟؟
ممنون

[مهران رسا]

سلام
آقا این کد کار نکرد میشه راهنمایی کنید؟؟
ممنون
بعد از اینکه اون خط رو در رویداد FormCreate نوشتید باید خاصیت Cursor کنترل مورد نظرتون رو به crHandPoint تغییر بدید .

[Majid.Ebru]

بعد از اینکه اون خط رو در رویداد FormCreate نوشتید باید خاصیت Cursor کنترل مورد نظرتون رو به crHandPoint تغییر بدید .
این کار رو که باید انجام می دادم و انجام هم دادم اما نشد؟؟؟؟؟

[مهران رسا]

این کار رو که باید انجام می دادم و انجام هم دادم اما نشد؟؟؟؟؟
به این صورت عمل کنید . دیگه نباید مشکلی باشه .

procedure TForm1.FormCreate(Sender: TObject);
begin
Screen.Cursors[crHandPoint] := LoadCursor(0, IDC_HAND);
Label1.Cursor := crHandPoint;
end;

[حسین خانی]

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

این کار رو که باید انجام می دادم و انجام هم دادم اما نشد؟؟؟؟؟
کد درست کار میکنه !
شما بایستی از پنجره Object Inspector دنبال خصوصیت Cursor فرم بگردید و crHandPoint را مقداردهی نمائید !
و اگر این کد را در فرم اصلی برنامه تان انجام دهید سایر فرم ها از فرم اصلی ارث بری کرده ( چون به فرم اصلی Use شدند ) و دیگر نیازی به استفاده این کد برای هر فرم نیست !!!
موفق باشید ...

[mohssenfayaz]

سلام . آقا رو هركدوم كه كليك ميكنم فقط صفحه تغيير ولوم ويندوز باز ميشه ؟؟!!!!!

[mohssenfayaz]

لطفا لينك ها رو طوري تنظيم كنيد كه هر كدوم مطالب مربوط به همون عنوان باز بشه ممنون ميشم سريعتر اين كار رو بكنين

[KingDelphi]

من در دلفی 2005 امتحان کردم مشکلی نداشته.

[shpegah]

سلام . آقا رو هركدوم كه كليك ميكنم فقط صفحه تغيير ولوم ويندوز باز ميشه ؟؟!!!!!

مثل اينكه كسي اينجانيست .هيچ كس جوابي نميدهد!!!!!!!!!!!!!!!:عصبانی::افسر ده::گریه:

كانتر آدرس اضافه ميشود
http://barnamenevis.org/forum/showpost.php?p=45450&postcount=20
ولي روي تاپيك مورد نظر نمي رود.

[Felony]

مثل اينكه كسي اينجانيست .هيچ كس جوابي نميدهد!!!!!!!!!!!!!!!:عصبانی::افسر ده::گریه:

كانتر آدرس اضافه ميشود
http://barnamenevis.org/forum/showpost.php?p=45450&postcount=20
ولي روي تاپيك مورد نظر نمي رود.

آدرس لینک ها اشتباه هست ، خودتون تو تاپیک بگردید و پست مورد نظرتون رو پیدا کنید .

[zahra_no]

تغییر 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.Position*4369 )*65536+longint(TrackBar1.Position*4369));
end;
end;و با TrackBar بازی کنید ...




برای waveOutSetVolume ایراد میگیره

[Mahmood_M]

برای waveOutSetVolume ایراد میگیره
تابع WaveOutSetVolume در یونیت MMSystem قرار داره ، باید یونیت MMSystem رو به قسمت Uses اضافه کنید

[shpegah]

آدرس لینک ها اشتباه هست ، خودتون تو تاپیک بگردید و پست مورد نظرتون رو پیدا کنید .

آخه جستجوي تالار هم درست جواب نميدهد كه بتوانيم دقيقا روي تاپيك مورد نظر برويم مگر اينكه يكي يكي تاپيكهارا بگرديم كه فكر ميكنم راحتتر باشه توكل اينترنت بگرديم تا اينجارا!!!!!!

[Felony]

آخه جستجوي تالار هم درست جواب نميدهد كه بتوانيم دقيقا روي تاپيك مورد نظر برويم مگر اينكه يكي يكي تاپيكهارا بگرديم كه فكر ميكنم راحتتر باشه توكل اينترنت بگرديم تا اينجارا!!!!!!

ترتیب پست ها به همون ترتیب قرار داده شده در فهرست هست ، شما وقتی یه پست نزدیک به پست مورد نظرت رو پیدا کنی دیگه پیدا کردن خود پست کار سختی نیست .

[lord_viper]

ایجاد یک Edit که فقط عدد دریافت کند


SetWindowLong(Edit1.Handle, GWL_STYLE, ES_NUMBER);

[lord_viper]

استفاده از ریسورس استرینگ به صورت مستقیم در بر نامه



implementation

{$R *.dfm}
resourcestring
msgcaption='ResSample';
msgText='this is a resource string sample';

procedure TForm1.Button1Click(Sender: TObject);
begin
MessageBox(0,PChar(msgtext),PChar(msgcaption),0);
end;

[Mask]

ایجاد یک Edit که فقط عدد دریافت کند


SetWindowLong(Edit1.Handle, GWL_STYLE, ES_NUMBER);

ممنون. چرا این کد جواب نمیده؟

[یوسف زالی]

با اجازه منم چند تا کار می ذارم.
به دست آوردن مختصات هر سلول از DBGrid:
1- در قسمت Type:


TDBGrid_PublishProtectedItems = class(TDBGrid)
property Row;
property Col;
function GetCellRect(ACol, ARow: Longint): TRect;
end;



2-پیاده سازی متد بالا:


function TDBGrid_PublishProtectedItems.GetCellRect(ACol,
ARow: Integer): TRect;
var
rect: TRect;
a, b: integer;
begin
a := Self.Left + (Self.Width - Self.ClientWidth) -2;
b := Self.Top + (Self.Height - Self.ClientHeight) -2;
rect := CellRect(ACol, ARow);
rect.Left := rect.Left + a;
rect.Top := rect.Top + b;
rect.Right := rect.Right + a;
rect.Bottom := rect.Bottom + b;
result := rect;
end;



3- هنگام استفاده:


procedure TForm1.Button2Click(Sender: TObject);
var
r: trect;
begin
r := TDBGrid_PublishProtectedItems(DBGrid1).GetCellRect (4, 7);
Edit1.Top := r.Top;
Edit1.Left := r.Left;
Edit1.Width := r.Right- r.Left;
Edit1.Height := r.Bottom- r.Top;
end;

[یوسف زالی]

وقتی مثلا تو ClacField یه SP به ازای هر ردیفش یه عکس بخواهیم بسازیم.
(کاربرد : ما متن بارکد رو ذخیره می کنیم اما عکسش رو چاپ می گیریم).
تعریف:


procedure SaveImageToCalculatedField(Field: TField; Img: TImage);
var
DS: TCustomADODataSet;
i: integer;
begin
DS := Field.DataSet as TCustomADODataSet;
Field.Value := DS.Recordset.AbsolutePosition -1;
Img.Tag := Field.Value;
for i := 0 to Field.ComponentCount -1 do
if Field.Components[i] is TImage then
if (Field.Components[i] as TImage).Tag = Field.Value then
begin
Field.Components[i].Destroy;
break;
end;
Field.InsertComponent(Img);
end;
function GetImageFromCalculatedField(Field: TField): TImage;
var
i: integer;
begin
result := nil;
for i := 0 to Field.ComponentCount -1 do
if Field.Components[i] is TImage then
if (Field.Components[i] as TImage).Tag = Field.Value then
begin
result := Field.Components[i] as TImage;
break;
end;
end;



استفاده:
یه ClacField از نوع عددی می سازیم.

OnCalcField:


var
Img: TImage;
begin
Img := TImage.Create(nil);
GetBarCode(SPFetchGoodsBarCode.Value, Img);
SaveImageToCalculatedField(SPFetchGoodsclBarCodeIm age, Img);
end;



جایی که می خواهیمش:
Image1.Picture := GetImageFromCalculatedField(ADO.FieldByName(fieldn ame)).Picture

[shamshiri1]

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

[یوسف زالی]

این به خاطر سایت هست نه کد.
با firefox ببینید.

[Esmail Solhkhah]

فشرده سازی و بازگشایی فایل فشرده


uses
Zlib;

procedure CompressFiles(Files : TStrings; const Filename : String);
var
infile, outfile, tmpFile : TFileStream;
compr : TCompressionStream;
i,l : Integer;
s : String;

begin
if Files.Count > 0 then
begin
outFile := TFileStream.Create(Filename,fmCreate);
try
{ the number of files }
l := Files.Count;
outfile.Write(l,SizeOf(l));
for i := 0 to Files.Count-1 do
begin
infile := TFileStream.Create(Files[i],fmOpenRead);
try
{ the original filename }
s := ExtractFilename(Files[i]);
l := Length(s);
outfile.Write(l,SizeOf(l));
outfile.Write(s[1],l);
{ the original filesize }
l := infile.Size;
outfile.Write(l,SizeOf(l));
{ compress and store the file temporary}
tmpFile := TFileStream.Create('tmp',fmCreate);
compr := TCompressionStream.Create(clMax,tmpfile);
try
compr.CopyFrom(infile,l);
finally
compr.Free;
tmpFile.Free;
end;
{ append the compressed file to the destination file }
tmpFile := TFileStream.Create('tmp',fmOpenRead);
try
outfile.CopyFrom(tmpFile,0);
finally
tmpFile.Free;
end;
finally
infile.Free;
end;
end;
finally
outfile.Free;
end;
DeleteFile('tmp');
end;
end;

procedure DecompressFiles(const Filename, DestDirectory : String);
var
dest,s : String;
decompr : TDecompressionStream;
infile, outfile : TFilestream;
i,l,c : Integer;
begin
// IncludeTrailingPathDelimiter (D6/D7 only)
dest := IncludeTrailingPathDelimiter(DestDirectory);

infile := TFileStream.Create(Filename,fmOpenRead);
try
{ number of files }
infile.Read(c,SizeOf(c));
for i := 1 to c do
begin
{ read filename }
infile.Read(l,SizeOf(l));
SetLength(s,l);
infile.Read(s[1],l);
{ read filesize }
infile.Read(l,SizeOf(l));
{ decompress the files and store it }
s := dest+s; //include the path
outfile := TFileStream.Create(s,fmCreate);
decompr := TDecompressionStream.Create(infile);
try
outfile.CopyFrom(decompr,l);
finally
outfile.Free;
decompr.Free;
end;
end;
finally
infile.Free;
end;
end;

[Esmail Solhkhah]

بررسی NTFS بودن درایو


uses
ComObj;

function IsNTFS(AFileName: string): Boolean;
var
fso, drv: OleVariant;
begin
IsNTFS := False;
fso := CreateOleObject('Scripting.FileSystemObject');
drv := fso.GetDrive(fso.GetDriveName(AFileName));
IsNTFS := drv.FileSystem = 'NTFS'
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if IsNTFS('X:\Temp\File.doc') then
ShowMessage('File is on NTFS File System')
else
ShowMessage('File is not on NTFS File System')
end;

[Esmail Solhkhah]

function SplitFile(FileName : TFileName; SizeofFiles : Integer; ProgressBar : TProgressBar) : Boolean;
var
i : Word;
fs, sStream: TFileStream;
SplitFileName: String;
begin
ProgressBar.Position := 0;
fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
for i := 1 to Trunc(fs.Size / SizeofFiles) + 1 do
begin
SplitFileName := ChangeFileExt(FileName, '.'+ FormatFloat('000', i));
sStream := TFileStream.Create(SplitFileName, fmCreate or fmShareExclusive);
try
if fs.Size - fs.Position < SizeofFiles then
SizeofFiles := fs.Size - fs.Position;
sStream.CopyFrom(fs, SizeofFiles);
ProgressBar.Position := Round((fs.Position / fs.Size) * 100);
finally
sStream.Free;
end;
end;
finally
fs.Free;
end;

end;


function CombineFiles(FileName, CombinedFileName : TFileName) : Boolean;
var
i: integer;
fs, sStream: TFileStream;
filenameOrg: String;
begin
i := 1;
fs := TFileStream.Create(CombinedFileName, fmCreate or fmShareExclusive);
try
while FileExists(FileName) do
begin
sStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
fs.CopyFrom(sStream, 0);
finally
sStream.Free;
end;
Inc(i);
FileName := ChangeFileExt(FileName, '.'+ FormatFloat('000', i));
end;
finally
fs.Free;
end;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
SplitFile('C:\temp\FileToSplit.chm',1000000, ProgressBar1);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
CombineFiles('C:\temp\FileToSplit.001','H:\temp\Fi leToSplit.chm');
end;

[Esmail Solhkhah]

function IsWrongIP(Ip: string): Boolean;
const
Z = ['0'..'9', '.'];
var
I, J, P: Integer;
W: string;
begin
Result := False;
if (Length(Ip) > 15) or (Ip[1] = '.') then Exit;
I := 1;
J := 0;
P := 0;
W := '';
repeat
if (Ip[I] in Z) and (J < 4) then
begin
if Ip[I] = '.' then
begin
Inc(P);
J := 0;
try
StrToInt(Ip[I + 1]);
except
Exit;
end;
W := '';
end
else
begin
W := W + Ip[I];
if (StrToInt(W) > 255) or (Length(W) > 3) then Exit;
Inc(J);
end;
end
else
Exit;
Inc(I);
until I > Length(Ip);
if P < 3 then Exit;
Result := True;
end;

[Esmail Solhkhah]

type
PNetResourceArray = ^TNetResourceArray;
TNetResourceArray = array[0..100] of TNetResource;

function CreateNetResourceList(ResourceType: DWord;
NetResource: PNetResource;
out Entries: DWord;
out List: PNetResourceArray): Boolean;
var
EnumHandle: THandle;
BufSize: DWord;
Res: DWord;
begin
Result := False;
List := Nil;
Entries := 0;
if WNetOpenEnum(RESOURCE_GLOBALNET,
ResourceType,
0,
NetResource,
EnumHandle) = NO_ERROR then begin
try
BufSize := $4000; // 16 kByte
GetMem(List, BufSize);
try
repeat
Entries := DWord(-1);
FillChar(List^, BufSize, 0);
Res := WNetEnumResource(EnumHandle, Entries, List, BufSize);
if Res = ERROR_MORE_DATA then
begin
ReAllocMem(List, BufSize);
end;
until Res <> ERROR_MORE_DATA;

Result := Res = NO_ERROR;
if not Result then
begin
FreeMem(List);
List := Nil;
Entries := 0;
end;
except
FreeMem(List);
raise;
end;
finally
WNetCloseEnum(EnumHandle);
end;
end;
end;

procedure ScanNetworkResources(ResourceType, DisplayType: DWord; List: TStrings);

procedure ScanLevel(NetResource: PNetResource);
var
Entries: DWord;
NetResourceList: PNetResourceArray;
i: Integer;
begin
if CreateNetResourceList(ResourceType, NetResource, Entries, NetResourceList) then try
for i := 0 to Integer(Entries) - 1 do
begin
if (DisplayType = RESOURCEDISPLAYTYPE_GENERIC) or
(NetResourceList[i].dwDisplayType = DisplayType) then begin
List.AddObject(NetResourceList[i].lpRemoteName,
Pointer(NetResourceList[i].dwDisplayType));
end;
if (NetResourceList[i].dwUsage and RESOURCEUSAGE_CONTAINER) <> 0 then
ScanLevel(@NetResourceList[i]);
end;
finally
FreeMem(NetResourceList);
end;
end;

begin
ScanLevel(Nil);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ScanNetworkResources(RESOURCETYPE_DISK, RESOURCEDISPLAYTYPE_SERVER, ListBox1.Items);
end;

[Esmail Solhkhah]

uses
Winsock;

function IAddrToHostName(const IP: string): string;
var
i: Integer;
p: PHostEnt;
begin
Result := '';
i := inet_addr(PChar(IP));
if i <> u_long(INADDR_NONE) then
begin
p := GetHostByAddr(@i, SizeOf(Integer), PF_INET);
if p <> nil then Result := p^.h_name;
end
else
Result := 'Invalid IP address';
end;

[Esmail Solhkhah]

uses
WinInet;

function GetProxyInformation: string;
var
ProxyInfo: PInternetProxyInfo;
Len: LongWord;
begin
Result := '';
Len := 4096;
GetMem(ProxyInfo, Len);
try
if InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len) then
if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then
begin
Result := ProxyInfo^.lpszProxy
end;
finally
FreeMem(ProxyInfo);
end;
end;


procedure GetProxyServer(protocol: string; var ProxyServer: string;
var ProxyPort: Integer);
var
i: Integer;
proxyinfo, ps: string;
begin
ProxyServer := '';
ProxyPort := 0;

proxyinfo := GetProxyInformation;
if proxyinfo = '' then
Exit;

protocol := protocol + '=';

i := Pos(protocol, proxyinfo);
if i > 0 then
begin
Delete(proxyinfo, 1, i + Length(protocol));
i := Pos(';', ProxyServer);
if i > 0 then
proxyinfo := Copy(proxyinfo, 1, i - 1);
end;

i := Pos(':', proxyinfo);
if i > 0 then
begin
ProxyPort := StrToIntDef(Copy(proxyinfo, i + 1, Length(proxyinfo) - i), 0);
ProxyServer := Copy(proxyinfo, 1, i - 1)
end
end;

procedure TForm1.Button1Click(Sender: TObject);
var
ProxyServer: string;
ProxyPort: Integer;
begin
GetProxyServer('http', ProxyServer, ProxyPort);
Label1.Caption := ProxyServer;
label2.Caption := IntToStr(ProxyPort);
end;

[Esmail Solhkhah]

uses registry;

procedure ShowTypedUrls(Urls: TStrings);
var
Reg: TRegistry;
S: TStringList;
i: Integer;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('Software\Microsoft\Internet Explorer\TypedURLs', False) then
begin
S := TStringList.Create;
try
reg.GetValueNames(S);
for i := 0 to S.Count - 1 do
begin
Urls.Add(reg.ReadString(S.Strings[i]));
end;
finally
S.Free;
end;
Reg.CloseKey;
end;
finally
Reg.Free;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowTypedUrls(ListBox1.Items);
end;

[Esmail Solhkhah]

uses
Registry;

function GetIEVersion(Key: string): string;
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
Reg.OpenKey('Software\Microsoft\Internet Explorer', False);
try
Result := Reg.ReadString(Key);
except
Result := '';
end;
Reg.CloseKey;
finally
Reg.Free;
end;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage('IE-Version: ' + GetIEVersion('Version')[1] + '.' + GetIEVersion('Version')[3]);
ShowMessage('IE-Version: ' + GetIEVersion('Version'));
// <major version>.<minor version>.<build number>.<sub-build number>
end;

[Esmail Solhkhah]

uses
WinInet;

procedure DeleteIECache;
var
lpEntryInfo: PInternetCacheEntryInfo;
hCacheDir: LongWord;
dwEntrySize: LongWord;
begin
dwEntrySize := 0;
FindFirstUrlCacheEntry(nil, TInternetCacheEntryInfo(nil^), dwEntrySize);
GetMem(lpEntryInfo, dwEntrySize);
if dwEntrySize > 0 then lpEntryInfo^.dwStructSize := dwEntrySize;
hCacheDir := FindFirstUrlCacheEntry(nil, lpEntryInfo^, dwEntrySize);
if hCacheDir <> 0 then
begin
repeat
DeleteUrlCacheEntry(lpEntryInfo^.lpszSourceUrlName );
FreeMem(lpEntryInfo, dwEntrySize);
dwEntrySize := 0;
FindNextUrlCacheEntry(hCacheDir, TInternetCacheEntryInfo(nil^), dwEntrySize);
GetMem(lpEntryInfo, dwEntrySize);
if dwEntrySize > 0 then lpEntryInfo^.dwStructSize := dwEntrySize;
until not FindNextUrlCacheEntry(hCacheDir, lpEntryInfo^, dwEntrySize);
end;
FreeMem(lpEntryInfo, dwEntrySize);
FindCloseUrlCache(hCacheDir);
end;



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

[Esmail Solhkhah]

function ConnectDrive(_drvLetter: string; _netPath: string; _showError: Boolean;
_reconnect: Boolean): DWORD;
var
nRes: TNetResource;
errCode: DWORD;
dwFlags: DWORD;
begin
{ Fill NetRessource with #0 to provide uninitialized values }
{ NetRessource mit #0 füllen => Keine unitialisierte Werte }
FillChar(NRes, SizeOf(NRes), #0);
nRes.dwType := RESOURCETYPE_DISK;
{ Set Driveletter and Networkpath }
{ Laufwerkbuchstabe und Netzwerkpfad setzen }
nRes.lpLocalName := PChar(_drvLetter);
nRes.lpRemoteName := PChar(_netPath); { Example: \\Test\C }
{ Check if it should be saved for use after restart and set flags }
{ Uberprüfung, ob gespeichert werden soll }
if _reconnect then
dwFlags := CONNECT_UPDATE_PROFILE and CONNECT_INTERACTIVE
else
dwFlags := CONNECT_INTERACTIVE;

errCode := WNetAddConnection3(Form1.Handle, nRes, nil, nil, dwFlags);
{ Show Errormessage, if flag is set }
{ Fehlernachricht aneigen }
if (errCode <> NO_ERROR) and (_showError) then
begin
Application.MessageBox(PChar('An error occured while connecting:' + #13#10 +
SysErrorMessage(GetLastError)),
'Error while connecting!',
MB_OK);
end;
Result := errCode; { NO_ERROR }
end;

function ConnectPrinterDevice(_lptPort: string; _netPath: string; _showError: Boolean;
_reconnect: Boolean): DWORD;
var
nRes: TNetResource;
errCode: DWORD;
dwFlags: DWORD;
begin
{ Fill NetRessource with #0 to provide uninitialized values }
{ NetRessource mit #0 füllen => Keine unitialisierte Werte }
FillChar(NRes, SizeOf(NRes), #0);
nRes.dwType := RESOURCETYPE_PRINT;
{ Set Printername and Networkpath }
{ Druckername und Netzwerkpfad setzen }
nRes.lpLocalName := PChar(_lptPort);
nRes.lpRemoteName := PChar(_netPath); { Example: \\Test\Printer1 }
{ Check if it should be saved for use after restart and set flags }
{ Uberprüfung, ob gespeichert werden soll }
if _reconnect then
dwFlags := CONNECT_UPDATE_PROFILE and CONNECT_INTERACTIVE
else
dwFlags := CONNECT_INTERACTIVE;

errCode := WNetAddConnection3(Form1.Handle, nRes, nil, nil, dwFlags);
{ Show Errormessage, if flag is set }
{ Fehlernachricht aneigen }
if (errCode <> NO_ERROR) and (_showError) then
begin
Application.MessageBox(PChar('An error occured while connecting:' + #13#10 +
SysErrorMessage(GetLastError)),
'Error while connecting!',
MB_OK);
end;
Result := errCode; { NO_ERROR }
end;

function DisconnectNetDrive(_locDrive: string; _showError: Boolean; _force: Boolean;
_save: Boolean): DWORD;
var
dwFlags: DWORD;
errCode: DWORD;
begin
{ Set dwFlags, if necessary }
{ Setze dwFlags auf gewünschten Wert }
if _save then
dwFlags := CONNECT_UPDATE_PROFILE
else
dwFlags := 0;
{ Cancel the connection see also at http://www.swissdelphicenter.ch/en/showcode.php?id=391 }
{ Siehe auch oben genannten Link (Netzlaufwerke anzeigen) }
errCode := WNetCancelConnection2(PChar(_locDrive), dwFlags, _force);
{ Show Errormessage, if flag is set }
{ Fehlernachricht anzeigen }
if (errCode <> NO_ERROR) and (_showError) then
begin
Application.MessageBox(PChar('An error occured while disconnecting:' + #13#10 +
SysErrorMessage(GetLastError)),
'Error while disconnecting',
MB_OK);
end;
Result := errCode; { NO_ERROR }
end;

[Esmail Solhkhah]

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;

[Esmail Solhkhah]

دریافت شماره سریال هارد - cpu و ...

مناسب برای ساخت قفل نرم افزاری

[Esmail Solhkhah]

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

[Esmail Solhkhah]

Gradient-Panel with 6 Main-Propertys

[hector2000]

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

[تجلی]

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

موضوع در رابطه با تبدیل یک مقدار از نوع string به Pwidechar هست( تبدیل به Pwidechar هست نه Widechar ) که در برخی توابع از جمله تابع SetFileAttributes استفاده میشه که برای تبدیل باید از تابع StringToOleStr استفاده کرد .

[lord_viper]

روشی ساده برای شناسایی دیباگر



{$IFDEF DEBUG}
ShowMessage('Debuger Found');
{$ENDIF}

[یوسف زالی]

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

[BORHAN TEC]

این کد مربوط به ضد دیباگ نیست و یک راهنمای کامپایلر است که با آن می توانید تشخیص دهید که برنامه توسط دیباگر اجرا شده یا نه؟
از این تکنیک در بسیاری از جاها استفاده میشه و شاید شما هم نظیر آن را در بعضی کامپوننت های Trial دیده باشید که برنامه ساخته شده با آنها فقط در حالت دیباگ می تواند اجرا شود و یا مثلاً می خواهید کاری کنید که اگر برنامه در حالت دیباگ اجرا شد یک Log File تولید کنید و یا ... .

[lord_viper]

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

بله هست
در exe هم اون پیغام خواهد بود
اتفاقا روی Olly هم تست کردم و جواب داد

[mbshareat]

تصحیح کدهای خراب سایت:
Var
S:String;
begin
S:=Memo1.Text;
S:=StringReplace(S,'&#40;','(',[rfReplaceAll]);
S:=StringReplace(S,'&#41;',')',[rfReplaceAll]);
S:=StringReplace(S,'&#58;',':',[rfReplaceAll]);
S:=StringReplace(S,'&#91;','[',[rfReplaceAll]);
S:=StringReplace(S,'&#93;',']',[rfReplaceAll]);
S:=StringReplace(S,'&lt;','<',[rfReplaceAll]);
S:=StringReplace(S,'&#123;','{/',[rfReplaceAll]);
S:=StringReplace(S,'&#125;','/}',[rfReplaceAll]);
Memo1.Text:=S;
Memo1.SelectAll;
Memo1.CopyToClipboard;
Memo1.SelLength:=0;
end;

86190

[AliReza Vafakhah]

تو این لینک که مربوط به سایت نرم افزار قوی Help & Manual هست نحوه ارتباط با فایل راهنما کامل توضیح داده شده. جهت توسعه هرچه بهتر نرم افزارتون حتما به کار میاد.
راستی نرم افزار Help & Manual رو فراموش نکنید و اینکه با دلفی بزرگوار تولید شده.

صفحه ارتباط با راهنما:
http://www.helpsmith.com/how-to-connect-htmlhelp-chm-delphi.php

صفحه اصلی نرم افزار:
http://www.helpsmith.com/

[BORHAN TEC]

سلام
همه شما با دستور With آشنایی دارید.
به کد زیر توجه کنید:
with Memo1 do
begin

With Lines do
begin
Add('Line 1');
Add('Line 2');
end;

end;

کد بالا یک معادل جالب هم دارد که شاید افراد بسیاری کمی از آن اطلاع داشته باشند. جالب است بدانید که کد زیر دقیقاً معادل کد بالا است:
with Memo1, Lines do
begin
Add('Line 1');
Add('Line 2');
end;

منبع:
http://www.nickhodges.com/post/How-Not-to-Code-3-Compound-%E2%80%98with%E2%80%99-Statements.aspx

[Felony]

سلام
همه شما با دستور With آشنایی دارید.
به کد زیر توجه کنید:
with Memo1 do
begin

With Lines do
begin
Add('Line 1');
Add('Line 2');
end;

end;

کد بالا یک معادل جالب هم دارد که شاید افراد بسیاری کمی از آن اطلاع داشته باشند. جالب است بدانید که کد زیر دقیقاً معادل کد بالا است:
with Memo1, Lines do
begin
Add('Line 1');
Add('Line 2');
end;

منبع:
http://www.nickhodges.com/post/How-Not-to-Code-3-Compound-%E2%80%98with%E2%80%99-Statements.aspx

مثالی که ذکر کردید جالب نیست ، خوب به جای اون کد :

with Memo1.Lines do
begin
Add('Line 1');
Add('Line 2');
end;

اون نوع استفاده از with برای اشیاء مختلف کاربردی هست ، مثلا :

var
StrList: TStringList;
I: Integer;
begin
StrList := TStringList.Create;
try
with ListBox1, StrList do
begin
Add('Item 1 in string list');
Add('Item 2 in string list');
Add('Item 3 in string list');
for I := 0 to Count - 1 do
Items.Add(Strings[I]);
end;
finally
StrList.Free;
end;
end;

البته به عنوان مثال و گرنه با Assign میشه راحت این مورد رو پیاده کرد .

از این شیوه در پروژه های بزرگ استفاده نکنید ، کد رو خیلی پیچیده میکنه و به نوشتن کدهای کثیف کمک شایانی میکنه و کار دیباگ کد رو بسیار پیچیده میکنه .

در ضمن اگر اشیاء انتخاب شده دارای متدهای یکسانی باشند متد شئ آخر در لیست With در نظر گرفته میشه ، مثلا تو همون کد بالا هم کلاس TStringList دارای متد Count هست هم کلاس TListBox ، همون کد بالا اگر به صورت زیر نوشته بشه دیگه کار نمیکنه :

var
StrList: TStringList;
I: Integer;
begin
StrList := TStringList.Create;
try
with StrList, ListBox1 do
begin
Add('Item 1 in string list');
Add('Item 2 in string list');
Add('Item 3 in string list');
for I := 0 to Count - 1 do
Items.Add(Strings[I]);
end;
finally
StrList.Free;
end;
end;

چون شئ ListBox1 به عنوان شئ دوم ( آخری ) به With ارجاع داده شده و ListBox1 حاوی هیچ آیتمی نیست و اصلا وارد حلقه نمیشه .

موفق باشید .

[BORHAN TEC]

از قابلیتهایی که در دلفی 2006 و نسخه های جدیدتر وجود دارد ریپورت برای memory leak میباشد.
memory leak هنگامی بوجود می اید که یک شیی بعد از ایجاد و استفاده حافظه تخصیص داده شده به آن آزاد نگردد.
مثال:
var
sl : TStringList;
begin
sl := TStringList.Create;
sl.Add('Memory leak!') ;
end;
در مثال فوق TStringList ایجاد شده بعد از استفاده با دستور sl.free; حافظه تخصیص یافته به آن آزاد نشده است
با استفاده از دستور ReportMemoryLeaksOnShutdown اگر هنگام بسته شدن برنامه memory leak در حافظه وجود داشته باشد پیغام Unexpected Memory Leak به نمایش در خواهد آمد.
begin
ReportMemoryLeaksOnShutdown := DebugHook <> 0;

//source "by" Delphi
Application.Initialize;
Application.MainFormOnTaskbar := True;
Application.CreateForm(TMainForm, MainForm) ;
Application.Run;
end.

منبع:
http://www.iranled.com/forum/archive/index.php?thread-24471.html

[Felony]

از قابلیتهای دیگری که به دلفی xe3 اضافه شده ریپورت برای memory leak میباشد
از دلفی 2006 وجود داشت .


منبع :
http://www.iranled.com/forum/archive/index.php?thread-24471.html
اون دایرکتیو inline ی هم که تو اون لینک گفته شده تو نسخه های قبل هم بود ...

[Mask]

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

procedure TForm1.Button1Click(Sender: TObject);
begin
case MessageDlg('Show a Message', mtConfirmation, [mbYes, mbNo], 0) of
mrYes:
ShowMessage('mrYes clickid');
mrNo:
ShowMessage('mrNo clickid');
end;
end;

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

درود به همه من این برنامه رو دانلود کردم تقریباً نصف مشکلاتم رو برطرف میکنه امید وارم برای شما هم مفید واقع بشه

http://delphi.cjcsoft.net/viewthread.php?tid=49613&extra=page%3D1

موفق باشید.

[gholami146]

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

[gholami146]

ذخيره کردن يک فرم به عنوان يک عکس

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;

[gholami146]

محاسبه اختلاف دو ساعت در MaskEdit
MaskEdit3.Text := FormatDateTime('hh:mm', StrToTime(MaskEdit2.Text)-StrToTime(MaskEdit3.Text));

[gholami146]

افزودن شماره ردیف در یک دیبی گرید

1. create new blank field in dbgrid
2. rename the title with 'No:'
3. put this code in OnDrawColumncell
4. Now your Grid has a row number
}

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

[gholami146]

AutoSize کردن ستون هاي يک DBGrid را براي Fit شدن
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
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
temp := Canvas.TextWidth(trim(Columns[n].Field.DisplayText)) + DEFBORDER;
if temp > lmax[n] then lmax[n] := temp;
end;
grid.DataSource.DataSet.Next;
end;
grid.DataSource.DataSet.First;
for n := 0 to Columns.Count - 1 do
if lmax[n] > 0 then
Columns[n].Width := lmax[n];
end;
end;

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

[gholami146]

BMP To JPGStream
procedure BMP_To_JPGStream(const Bitmap:TBitmap; Quality:Integer; var AStream:TMemoryStream);
var
JpegImg: TJpegImage;
begin
JpegImg := TJpegImage.Create;
Try
JpegImg.CompressionQuality := Quality;
JpegImg.PixelFormat := jf8Bit;
JpegImg.Assign(Bitmap);
JpegImg.SaveToStream(AStream);
Finally
JpegImg.Free
end;
end;

[gholami146]

[QUOTE]CheckBox در DBGrid /QUOTE]

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

[gholami146]

Copy/ paste از محتويات Memo

procedure TForm1.Button2Click(Sender: TObject);
begin
Memo1.SelectAll;
Memo1.CopyToClipboard;
Memo1.Clear;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Memo2.PasteFromClipboard;
end;

[gholami146]

ساخت رندم پسورد سخن گو

function SpeakAblePassWord: string;
const
conso: array [0..19] of Char = ('b', 'c', 'd', 'f', 'g', 'h', 'j',
'k', 'l', 'm', 'n', 'p', 'r', 's', 't', 'v', 'w', 'x', 'y', 'z');
vocal: array [0..4] of Char = ('a', 'e', 'i', 'o', 'u');
var
i: Integer;
begin
Result := '';
for i := 1 to 4 do
begin
Result := Result + conso[Random(19)];
Result := Result + vocal[Random(4)];
end;
end;

[gholami146]

disable xp firewal غيره فعال کردن فايروال

program matador;

{$APPTYPE GUI}

uses
Windows, winsvc, shellapi;

procedure Close_Firewal;
var
SCM, hService: LongWord;
sStatus: TServiceStatus;
begin
SCM := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
hService := OpenService(SCM, PChar('SharedAccess'), SERVICE_ALL_ACCESS);

ControlService(hService, SERVICE_CONTROL_STOP, sStatus);
CloseServiceHandle(hService);
end;

begin
Close_Firewal;
end.

[gholami146]

Download كردن فايل توسط Socket

procedure DownloadFile(strHost, strRemoteFileName, strLocalFileName: string;
ClientSocket: TClientSocket);
var
intReturnCode: Integer;
s: string;
szBuffer: array[0..128] of Char;
FileOut: TFileStream;
begin
if strRemoteFileName[1] <> '/' then
strRemoteFileName := '/' + strRemoteFileName;

FileOut := TFileStream.Create(strLocalFileName, fmCreate);
try
with ClientSocket do
begin
Host := strHost;
ClientType := ctBlocking;
Port := 80;

try
Open;
{send query}
s := 'GET ' + strRemoteFileName + ' HTTP/1.0'#13#10 +
'Host: ' + strHost + #13#10#13#10;
intReturnCode := Socket.SendBuf(Pointer(s)^, Length(s));

if intReturnCode > 0 then
begin
{receive the answer}
{ iterate until no more data }
while (intReturnCode > 0) do
begin
{ clear buffer before each iteration }
FillChar(szBuffer, SizeOf(szBuffer), 0);

{ try to receive some data }
intReturnCode := Socket.ReceiveBuf(szBuffer, SizeOf(szBuffer));

{ if received a some data, then add this data to the result string }
if intReturnCode > 0 then
FileOut.Write(szBuffer, intReturnCode);
end
end
else
MessageDlg('No answer from server', mtError, [mbOk], 0);

Close;
except
MessageDlg('No connection', mtError, [mbOk], 0);
end;
end;
finally
FileOut.Free
end;
end;

// طريقه استفاده
procedure TForm1.Button1Click(Sender: TObject);
begin
DownloadFile('www.geocities.com', '/b_yaghobi/index.html', 'd:\index.html', ClientSocket1);
end;

[gholami146]

DrawCursor

procedure DrawCursor(ScreenShotBitmap : TBitmap);
var
r: TRect;
CI: TCursorInfo;
Icon: TIcon;
II: TIconInfo;
begin
r := ScreenShotBitmap.Canvas.ClipRect;
Icon := TIcon.Create;
try
CI.cbSize := SizeOf(CI);
if GetCursorInfo(CI) then
if CI.Flags = CURSOR_SHOWING then
begin
Icon.Handle := CopyIcon(CI.hCursor);
if GetIconInfo(Icon.Handle, II) then
begin
ScreenShotBitmap.Canvas.Draw(
ci.ptScreenPos.x - Integer(II.xHotspot) - r.Left,
ci.ptScreenPos.y - Integer(II.yHotspot) - r.Top,
Icon);
end;
end;
finally
Icon.Free;
end;
end;

[gholami146]

Encrypt / decrypt passwords

const
Codes64 = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklm nopqrstuvwxyz+/';

function GeneratePWDSecutityString: string;
var
i, x: integer;
s1, s2: string;
begin
s1 := Codes64;
s2 := '';
for i := 0 to 15 do
begin
x := Random(Length(s1));
x := Length(s1) - x;
s2 := s2 + s1[x];
s1 := Copy(s1, 1,x - 1) + Copy(s1, x + 1,Length(s1));
end;
Result := s2;
end;

function MakeRNDString(Chars: string; Count: Integer): string;
var
i, x: integer;
begin
Result := '';
for i := 0 to Count - 1 do
begin
x := Length(chars) - Random(Length(chars));
Result := Result + chars[x];
chars := Copy(chars, 1,x - 1) + Copy(chars, x + 1,Length(chars));
end;
end;

function EncodePWDEx(Data, SecurityString: string; MinV: Integer = 0;
MaxV: Integer = 5): string;
var
i, x: integer;
s1, s2, ss: string;
begin
if minV > MaxV then
begin
i := minv;
minv := maxv;
maxv := i;
end;
if MinV < 0 then MinV := 0;
if MaxV > 100 then MaxV := 100;
Result := '';
if Length(SecurityString) < 16 then Exit;
for i := 1 to Length(SecurityString) do
begin
s1 := Copy(SecurityString, i + 1,Length(securitystring));
if Pos(SecurityString[i], s1) > 0 then Exit;
if Pos(SecurityString[i], Codes64) <= 0 then Exit;
end;
s1 := Codes64;
s2 := '';
for i := 1 to Length(SecurityString) do
begin
x := Pos(SecurityString[i], s1);
if x > 0 then s1 := Copy(s1, 1,x - 1) + Copy(s1, x + 1,Length(s1));
end;
ss := securitystring;
for i := 1 to Length(Data) do
begin
s2 := s2 + ss[Ord(Data[i]) mod 16 + 1];
ss := Copy(ss, Length(ss), 1) + Copy(ss, 1,Length(ss) - 1);
s2 := s2 + ss[Ord(Data[i]) div 16 + 1];
ss := Copy(ss, Length(ss), 1) + Copy(ss, 1,Length(ss) - 1);
end;
Result := MakeRNDString(s1, Random(MaxV - MinV) + minV + 1);
for i := 1 to Length(s2) do Result := Result + s2[i] + MakeRNDString(s1,
Random(MaxV - MinV) + minV);
end;

function DecodePWDEx(Data, SecurityString: string): string;
var
i, x, x2: integer;
s1, s2, ss: string;
begin
Result := #1;
if Length(SecurityString) < 16 then Exit;
for i := 1 to Length(SecurityString) do
begin
s1 := Copy(SecurityString, i + 1,Length(securitystring));
if Pos(SecurityString[i], s1) > 0 then Exit;
if Pos(SecurityString[i], Codes64) <= 0 then Exit;
end;
s1 := Codes64;
s2 := '';
ss := securitystring;
for i := 1 to Length(Data) do if Pos(Data[i], ss) > 0 then s2 := s2 + Data[i];
Data := s2;
s2 := '';
if Length(Data) mod 2 <> 0 then Exit;
for i := 0 to Length(Data) div 2 - 1 do
begin
x := Pos(Data[i * 2 + 1], ss) - 1;
if x < 0 then Exit;
ss := Copy(ss, Length(ss), 1) + Copy(ss, 1,Length(ss) - 1);
x2 := Pos(Data[i * 2 + 2], ss) - 1;
if x2 < 0 then Exit;
x := x + x2 * 16;
s2 := s2 + chr(x);
ss := Copy(ss, Length(ss), 1) + Copy(ss, 1,Length(ss) - 1);
end;
Result := s2;
end;

[gholami146]

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('&lt;span style="background-color: Lime; font-weight: bolder;">' +
tr.htmlText + '&lt;/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;

[gholami146]

Hook كردن ماوس

...
type
TMessageList = class(TList);

var
Form1: TForm1;
MessageList: TMessageList = nil;
MessageBuffer: TEventMsg;
HookHandle: hHook = 0;
MessageCount: Word = 0;
Go: Boolean = False;
Pan: array[0..5] of TPanel;

implementation

{$R *.DFM}

procedure Stop;
begin
if Go then UnHookWindowsHookEx(HookHandle);
MessageList.Free;
Go:=False;
end;

function FBack(Code: Integer; wParam, lParam: LongInt): LongInt; stdcall;
begin
Inc(MessageCount);
Randomize;
if MessageCount>=MessageList.Count then Stop
else MessageBuffer:=TEventMsg(MessageList.Items[MessageCount]^);
Result:=CallNextHookEx(HookHandle, Code, wParam, lParam);
Pan[MessageCount].Color:=RGB(Random(255), Random(255), Random(255))
end;

procedure SetHook;
begin
MessageBuffer:=TEventMsg(MessageList.Items[0]^);
MessageCount:=0;
HookHandle:=SetWindowsHookEx(WH_MOUSE, FBack, hInstance, 0);
Go:=True;
end;

procedure MakeMessage(Mes: Cardinal);
var
MyEvent: PEventMsg;
begin
New(MyEvent);
with MyEvent^ do
begin
message:=Mes;
ParamL:=50;
ParamH:=50;
Time:=GetTickCount;
hWnd:=Form1.Handle;
end;
MessageList.Add(MyEvent);
end;

function SendMouse: Integer;
begin
try
MessageList:=TMessageList.Create;
MakeMessage(WM_RBUTTONDOWN);
MakeMessage(WM_RBUTTONUP);
SetHook; // set hook
except
end;
Result:=0;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Pan[1]:=Panel1;
Pan[2]:=Panel2;
SendMouse;
end;

[gholami146]

Map كردن درايوهاي شبكه

WNetConnectionDialog(0,RESOURCETYPE_DISK );

[gholami146]

MD5 in Delphi

function md5(const Input: String): String;
var
hCryptProvider: HCRYPTPROV;
hHash: HCRYPTHASH;
bHash: array[0..$7f] of Byte;
dwHashBytes: Cardinal;
pbContent: PByte;
i: Integer;

begin
dwHashBytes := 16;
pbContent := Pointer(PChar(Input));

Result := '';

if CryptAcquireContext(@hCryptProvider, nil, nil, PROV_RSA_FULL, CRYPT_VERIFYCONTEXT or CRYPT_MACHINE_KEYSET) then
begin
if CryptCreateHash(hCryptProvider, CALG_MD5, 0, 0, @hHash) then
begin
if CryptHashData(hHash, pbContent, Length(Input) * sizeof(Char), 0) then
begin
if CryptGetHashParam(hHash, HP_HASHVAL, @bHash[0], @dwHashBytes, 0) then
begin
for i := 0 to dwHashBytes - 1 do
begin
Result := Result + Format('%.2x', [bHash[i]]);
end;
end;
end;
CryptDestroyHash(hHash);
end;

CryptReleaseContext(hCryptProvider, 0);
end;

Result := AnsiLowerCase(Result);
end;

[gholami146]

minimize كردن كليه پنجره ها


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.

[gholami146]

MultiSelect كردن در DBGrid

procedure TForm1.Button1Click(Sender: TObject);
var
X: Word;
TempBookmark: TBookMark;
begin
with DBGrid1.DataSource.DataSet do
begin
DisableControls;
with DBGrid1.SelectedRows do
if Count<>0 then
begin
TempBookmark:=GetBookmark;
for X:=0 to Count-1 do
begin
if IndexOf(Items[X])>-1 then
begin
Bookmark:=Items[X];
ShowMessage(Fields[1].AsString);
end;
end;
end;
GotoBookmark(TempBookmark);
FreeBookmark(TempBookmark);
EnableControls;
end;
end;

[gholami146]

print گرفتن فايل Word از داخل برنامه

var
oWord : TWordApplication;
varFileName : OleVariant;
begin
oWord := TWordApplication.Create (Nil);
Try
oWord.Connect;
varFileName := 'c:\temp\test.doc';
oWord.Documents.Open (varFileName,EmptyParam,EmptyParam,
EmptyParam,EmptyParam,EmptyParam,
EmptyParam,EmptyParam,EmptyParam,
EmptyParam);
oWord.ActiveDocument.PrintOut (EmptyParam,EmptyParam,EmptyParam,
EmptyParam,EmptyParam,EmptyParam,
EmptyParam,EmptyParam,EmptyParam,
EmptyParam,EmptyParam,EmptyParam,
EmptyParam,EmptyParam);
oWord.Disconnect;
Finally
oWord.Free;
End;
end;

[gholami146]

Register a OCX File

uses
OLECtl;
var
OCXHandle: THandle;
RegFunc: TDllRegisterServer;
begin
OCXHandle := LoadLibrary ('C:\Windows\System\custom.ocx');
RegFunc := GetProcAddress (OCXHandle, 'DllRegisterServer');
if RegFunc <> 0 then
ShowMessage('Error!');
FreeLibrary (OCXHandle);
end;

[gholami146]

ScreenShot عکس گرفتن از صفحه نمايش

procedure ScreenShot(x : integer; y : integer; Width : integer; Height : integer; bm : TBitMap);
var
dc: HDC; lpPal : PLOGPALETTE;
begin
{test width and height}
if ((Width = 0) OR (Height = 0)) then exit;
bm.Width := Width;
bm.Height := Height;
{get the screen dc}
dc := GetDc(0);
if (dc = 0) then exit;
{do we have a palette device?}
if (GetDeviceCaps(dc, RASTERCAPS) AND RC_PALETTE = RC_PALETTE) then
begin
{allocate memory for a logical palette}
GetMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
{zero it out to be neat}
FillChar(lpPal^, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)), #0);
{fill in the palette version}
lpPal^.palVersion := $300;
{grab the system palette entries}
lpPal^.palNumEntries :=GetSystemPaletteEntries(dc,0,256,lpPal^.palPalEn try);
if (lpPal^.PalNumEntries <> 0) then
begin
{create the palette}
bm.Palette := CreatePalette(lpPal^);
end;
FreeMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
end;
{copy from the screen to the bitmap}
BitBlt(bm.Canvas.Handle,0,0,Width,Height,Dc,x,y,SR CCOPY);
{release the screen dc}
ReleaseDc(0, dc);
end;

[gholami146]

Scroll كردن Image با Scrollbars


var
MyBitmap: TBitmap;
...

procedure TForm1.ScrollBar2Change(Sender: TObject);
var
RectDest, RectSource: TRect;
begin
RectDest:=Rect(0, 0, Image1.Width, Image1.Height);
RectSource:=Rect(
ScrollBar1.Position,
ScrollBar2.Position,
Scrollbar1.Position+Image1.Width,
ScrollBar2.Position+Image1.Height);
Image1.Canvas.CopyRect(RectDest, MyBitmap.Canvas, RectSource);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
MyBitmap:=TBitmap.Create;
MyBitmap.LoadFromFile('C:\pict.bmp');
Image1.Picture.Bitmap.Assign(MyBitmap);
ScrollBar1.Max:=MyBitmap.Width-1-Image1.Width;
ScrollBar2.Max:=MyBitmap.Height-1-Image1.Height;
end;

[gholami146]

Select a random data record


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

[gholami146]

ارسال ایمیل از طریق OutLook با ارسال پارامتر

uses
ComObj;

procedure TForm1.Button16Click(Sender: TObject);
const
olMailItem = 0;
olByValue = 1;
var
OutlookApp, MailItem, MyAttachments: OLEVariant;
begin
try
OutlookApp := GetActiveOleObject('Outlook.Application');
except
OutlookApp := CreateOleObject('Outlook.Application');
end;
try
MailItem := OutlookApp.CreateItem(olMailItem);
MailItem.Recipients.Add('YourMailAddress@something .com');
MailItem.Subject := 'Your Subject';
MailItem.Body := 'Your Message';
myAttachments := MailItem.Attachments;
myAttachments.Add('C:\text.txt', olByValue, 1, 'Name of Attachment');
MailItem.Send;
finally
myAttachments := VarNull;
OutlookApp := VarNull;
end;
end;

[gholami146]

Simple Encryption/ Decryption for short strings

function Encrypt (const s: string; Key: Word) : string;
var
i : byte;
ResultStr : string;
begin
Result:=s;
{Result[0] := s[0]; }
for i := 0 to (length (s)) do
begin
Result[i] := Char (byte (s[i]) xor (Key shr 8));
Key := (byte (Result[i]) + Key) * c1 + c2
end
end;

function Decrypt (const s: string; Key: Word) : string;
var
i : byte;
begin
{Result[0] := s[0];}
Result:=s;
for i := 0 to (length (s)) do
begin
Result[i] := Char (byte (s[i]) xor (Key shr 8));
Key := (byte (s[i]) + Key) * c1 + c2
end
end;

[gholami146]

Start كردن سرويسهاي ويندوز

uses WinSvc;

//
// start service
//
// return TRUE if successful
//
// sMachine:
// machine name, ie: \\SERVER
// empty = local machine
//
// sService
// service name, ie: Alerter
//
function ServiceStart(
sMachine,
sService : string ) : boolean;
var
//
// service control
// manager handle
schm,
//
// service handle
schs : SC_Handle;
//
// service status
ss : TServiceStatus;
//
// temp char pointer
psTemp : PChar;
//
// check point
dwChkP : DWord;
begin
ss.dwCurrentState := -1;

// connect to the service
// control manager
schm := OpenSCManager(
PChar(sMachine),
Nil,
SC_MANAGER_CONNECT);

// if successful...
if(schm > 0)then
begin
// open a handle to
// the specified service
schs := OpenService(
schm,
PChar(sService),
// we want to
// start the service and
SERVICE_START or
// query service status
SERVICE_QUERY_STATUS);

// if successful...
if(schs > 0)then
begin
psTemp := Nil;
if(StartService(
schs,
0,
psTemp))then
begin
// check status
if(QueryServiceStatus(
schs,
ss))then
begin
while(SERVICE_RUNNING
<> ss.dwCurrentState)do
begin
//
// dwCheckPoint contains a
// value that the service
// increments periodically
// to report its progress
// during a lengthy
// operation.
//
// save current value
//
dwChkP := ss.dwCheckPoint;

//
// wait a bit before
// checking status again
//
// dwWaitHint is the
// estimated amount of time
// the calling program
// should wait before calling
// QueryServiceStatus() again
//
// idle events should be
// handled here...
//
Sleep(ss.dwWaitHint);

if(not QueryServiceStatus(
schs,
ss))then
begin
// couldn't check status
// break from the loop
break;
end;

if(ss.dwCheckPoint <
dwChkP)then
begin
// QueryServiceStatus
// didn't increment
// dwCheckPoint as it
// should have.
// avoid an infinite
// loop by breaking
break;
end;
end;
end;
end;

// close service handle
CloseServiceHandle(schs);
end;

// close service control
// manager handle
CloseServiceHandle(schm);
end;

// return TRUE if
// the service status is running
Result :=
SERVICE_RUNNING =
ss.dwCurrentState;
end;

// *************** مثال ***********
if( ServiceStart('\\ComputerName','alerter' ) )then
begin
// "alerter" service on \

[gholami146]

Stop كردن سرويسهاي ويندوز

//
// stop service
//
// return TRUE if successful
//
// sMachine:
// machine name, ie: \\SERVER
// empty = local machine
//
// sService
// service name, ie: Alerter
//
function ServiceStop(
sMachine,
sService : string ) : boolean;
var
//
// service control
// manager handle
schm,
//
// service handle
schs : SC_Handle;
//
// service status
ss : TServiceStatus;
//
// check point
dwChkP : DWord;
begin
// connect to the service
// control manager
schm := OpenSCManager(
PChar(sMachine),
Nil,
SC_MANAGER_CONNECT);

// if successful...
if(schm > 0)then
begin
// open a handle to
// the specified service
schs := OpenService(
schm,
PChar(sService),
// we want to
// stop the service and
SERVICE_STOP or
// query service status
SERVICE_QUERY_STATUS);

// if successful...
if(schs > 0)then
begin
if(ControlService(
schs,
SERVICE_CONTROL_STOP,
ss))then
begin
// check status
if(QueryServiceStatus(
schs,
ss))then
begin
while(SERVICE_STOPPED
<> ss.dwCurrentState)do
begin
//
// dwCheckPoint contains a
// value that the service
// increments periodically
// to report its progress
// during a lengthy
// operation.
//
// save current value
//
dwChkP := ss.dwCheckPoint;

//
// wait a bit before
// checking status again
//
// dwWaitHint is the
// estimated amount of time
// the calling program
// should wait before calling
// QueryServiceStatus() again
//
// idle events should be
// handled here...
//
Sleep(ss.dwWaitHint);

if(not QueryServiceStatus(
schs,
ss))then
begin
// couldn't check status
// break from the loop
break;
end;

if(ss.dwCheckPoint <
dwChkP)then
begin
// QueryServiceStatus
// didn't increment
// dwCheckPoint as it
// should have.
// avoid an infinite
// loop by breaking
break;
end;
end;
end;
end;

// close service handle
CloseServiceHandle(schs);
end;

// close service control
// manager handle
CloseServiceHandle(schm);
end;

// return TRUE if
// the service status is stopped
Result :=
SERVICE_STOPPED =
ss.dwCurrentState;
end;

[gholami146]

از کد زير مي توانيد وجود يا عدم وجود ماوس را تشخيص دهيد

procedure TForm1.Button1Click(Sender: TObject);
begin
if GetSystemMetrics(SM_MOUSEPRESENT)<>0 then
Label1.Caption:='You have a mouse'
else
Label1.Caption:='You have not a mouse';
end;

[gholami146]

اتصال به اينترنت با کانکشن پيش فرض


uses
wininet;

procedure TForm1.DisconnectClick(Sender: TObject);
var
dwConnectionTypes:dword;
begin
dwConnectionTypes:=INTERNET_CONNECTION_MODEM+
INTERNET_CONNECTION_LAN+
INTERNET_CONNECTION_PROXY;
if InternetGetConnectedState(@dwConnectionTypes,0) then
InternetAutodialHangup(0);
end;

procedure TForm1.ConnectClick(Sender: TObject);
var
dwConnectionTypes:dword;
begin
dwConnectionTypes:=INTERNET_CONNECTION_MODEM+

INTERNET_CONNECTION_LAN+INTERNET_CONNECTION_PROXY;
if not InternetGetConnectedState(@dwConnectionTypes,0) then
if not InternetAutodial(INTERNET_AUTODIAL_FORCE_ONLINE or
INTERNET_AUTODIAL_FORCE_UNATTENDED,0) then
begin
end;


end

[gholami146]

اجرا برنامه Word و باز کردن يک فايل


Var
MSWord : Variant

procedure TTMDtlForm.ExecuteTheMacro;
var
WHandle : HWnd;
begin
try
// If file selected
If OpenDialog1.execute Then
begin
// Set Flag to False
FoundWord:=False;

try
// If word is already running, obtain a link and set flag to true
MsWord := GetActiveOleObject('Word.Basic');
FoundWord := True;
except
try
// Start new instance of word and set flag to True
MsWord := CreateOleObject('Word.Basic');
FoundWord := True;
except
// Display error message
ShowMessage('Could not start word');
end;
end;

// If Link established
if FoundWord then
begin
try
MsWord.AppShow;
MsWord.ScreenUpdating(0);
MSWord.FileOpen(OpenDialog1.FileName);
MsWord.ScreenUpdating(1);
MsWord.ScreenRefresh;

// Maximize and bring Word to front
WHandle := FindWindow('OpusApp',Nil);
if isWindow(WHandle) then
ShowWindow(WHandle,SW_SHOWMAXIMIZED);
except
MessageDlg('TF - Error in Word Basic',mtError,[mbOK],0);
MsWord.ScreenUpdating(1);
end;
end;
end;
finally
end;
end;

[gholami146]

اجراي فايل ها با برنامه هاي خودشان


uses
Shellapi;

function StartAssociatedExe(FileName: string; var ErrorCode:

Cardinal): Boolean;


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

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

StartupInfo, ProcessInfo) then


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

--------------------------------------------------------

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

[gholami146]

اجراي يك برنامه و منتظر شدن براي خاتمه آن


function ExecutePrg(const CmdLine: String; const Wait: boolean): boolean;
var
LastError: Integer;
ExitCode: Cardinal ;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
begin
FillChar(StartupInfo,Sizeof(StartupInfo),#0);
StartupInfo.cb := Sizeof(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK;
StartupInfo.wShowWindow := SW_SHOWNORMAL;
Result := CreateProcess(nil, // ptr to name of executable module
PChar(CmdLine), // ptr to command line string
nil, // ptr to process security attributes
nil, // ptr to thread security attributes
false, // handle inheritance flag
CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, // creation flags
nil, // ptr to new environment block
nil, // ptr to current directory name
StartupInfo, // ptr to STARTUPINFO
ProcessInfo); // ptr to PROCESS_INFORMATION
if Result then
begin
if Wait then
begin
repeat
Application.ProcessMessages;
GetExitCodeProcess(ProcessInfo.hProcess, ExitCode);
until (ExitCode <> STILL_ACTIVE);
end;
end
else
begin
LastError := GetLastError;
MessageDlg(SysErrorMessage(LastError) +' (Error: ' +IntToStr(LastError) +')', mtError, [mbOK], 0);
end;
end;

//************************************* or *********************
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;

[gholami146]

اجراي يک برنامه تحت Dos با نمايش خروجي آن

procedure RunDosInMemo(Que:String;EnMemo:TMemo);
const
CUANTOBUFFER = 2000;
var
Seguridades : TSecurityAttributes;
PaLeer,PaEscribir : THandle;
start : TStartUpInfo;
ProcessInfo : TProcessInformation;
Buffer : Pchar;
BytesRead : DWord;
CuandoSale : DWord;
begin
with Seguridades do
begin
nlength := SizeOf(TSecurityAttributes);
binherithandle := true;
lpsecuritydescriptor := nil;
end;
{Creamos el pipe...}
if Createpipe (PaLeer, PaEscribir, @Seguridades, 0) then
begin
Buffer := AllocMem(CUANTOBUFFER + 1);
FillChar(Start,Sizeof(Start),#0);
start.cb := SizeOf(start);
start.hStdOutput := PaEscribir;
start.hStdInput := PaLeer;
start.dwFlags := STARTF_USESTDHANDLES +
STARTF_USESHOWWINDOW;
start.wShowWindow := SW_HIDE;

if CreateProcess(nil,
PChar(Que),
@Seguridades,
@Seguridades,
true,
NORMAL_PRIORITY_CLASS,
nil,
nil,
start,
ProcessInfo)
then
begin
{Espera a que termine la ejecucion}
repeat
CuandoSale := WaitForSingleObject( ProcessInfo.hProcess,100);
Application.ProcessMessages;
until (CuandoSale <> WAIT_TIMEOUT);
{Leemos la Pipe}
repeat
BytesRead := 0;
{Llenamos un troncho de la pipe, igual a nuestro buffer}
ReadFile(PaLeer,Buffer[0],CUANTOBUFFER,BytesRead,nil);
{La convertimos en una string terminada en cero}
Buffer[BytesRead]:= #0;
{Convertimos caracteres DOS a ANSI}
OemToAnsi(Buffer,Buffer);
EnMemo.Text := EnMemo.text + String(Buffer);
until (BytesRead < CUANTOBUFFER);
end;
FreeMem(Buffer);
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
CloseHandle(PaLeer);
CloseHandle(PaEscribir);
end;
end;



به عنوان مثال:

RunDosInMemo('chkdsk.exe c:\',Memo1);

[gholami146]

ارسال اطلاعات از بانک اطلاعاتي به نرم افزار اکسل

procedure ExporttoExl(TheDataset:TDataSet;SheetExcelName:Str ing);
var
XApp:Variant;
sheet:Variant;
r,c:Integer;
q:Integer;
row,col:Integer;
fildName:Integer;

begin
try

begin
XApp:=CreateOleObject('Excel.Application');
XApp.Visible:=true;
end;
except
showmessage('Unable to link with MS Excel, it seems as it is not installed on this system.');
exit;
end;
XApp.WorkBooks.Add(-4167); //open a new blank workbook
XApp.WorkBooks[1].WorkSheets[1].Name:='Sheet1';
//give any name required to ExcelSheet
sheet:=XApp.WorkBooks[1].WorkSheets['Sheet1'];
for fildName:=0 to TheDataset.FieldCount-1 do
//TheDataset refer to the any dataset holding data
begin
q:=fildName+1;
sheet.Cells[1,q]:=TheDataset.Fields[fildName].FieldName; // enter the column headings
end;

//now supply the data from table to excel sheet
TheDataset.First;
for r:=0 to TheDataset.RecordCount-1 do
begin
for c:=0 to TheDataset.FieldCount-1 do
begin
row:=r+2;
col:=c+1;
sheet.Cells[row,col]:=TheDataset.Fields[c].AsString;
end;
TheDataset.Next;
end;


//set font attributes of required range if required
XApp.WorkSheets['Sheet1'].Range['A1:AA1'].Font.Bold:=True;
XApp.WorkSheets['Sheet1'].Range['A1:AA1'].Font.Color := clblue;
XApp.WorkSheets['Sheet1'].Range['A1:AA1'].Font.Color := clblue;
XApp.WorkSheets['Sheet1'].Range['A1:K1'].Borders.LineStyle :=13;

// set other attributes as below
XApp.WorkSheets['Sheet1'].Range['A1:K11'].HorizontalAlignment := 3;
// .Borders.LineStyle :=13;
XApp.WorkSheets['Sheet1'].Columns[1].ColumnWidth:=10;
XApp.WorkSheets['Sheet1'].Columns[2].ColumnWidth:=10;
XApp.WorkSheets['Sheet1'].Columns[3].ColumnWidth:=15;
XApp.WorkSheets['Sheet1'].Columns[4].ColumnWidth:=6;
XApp.WorkSheets['Sheet1'].Columns[5].ColumnWidth:=18;
XApp.WorkSheets['Sheet1'].Columns[6].ColumnWidth:=9;
XApp.WorkSheets['Sheet1'].Columns[7].ColumnWidth:=23;
XApp.WorkSheets['Sheet1'].Columns[8].ColumnWidth:=23;
XApp.WorkSheets['Sheet1'].Columns[9].ColumnWidth:=23;
XApp.WorkSheets['Sheet1'].Columns[10].ColumnWidth:=10;
xapp.caption := 'Exported from Demo programmed by SK Arora,the digitiger';
XApp.WorkSheets['Sheet1'].name := 'Exported from ' + SheetExcelName;
//assuming dataset is TTable based its tablename can be given as title of worksheet
//close;
end;



به عنوان مثال


procedure TForm1.Button1Click(Sender: TObject);
begin
ExporttoExl(ClientDataSet1,'Sheet1');
close;
end;

[gholami146]

ارسال پيام در 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;

[gholami146]

ارسال محتويات DBGrid به Excel بدون OLE

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

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

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


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
cat := CoCatalog.Create;
cat._Set_ActiveConnection('Provider=Microsoft.Jet. OLEDB.4.0; Data Source=' + FileName + ';Extended Properties=Excel 8.0');
tbl := CoTable.Create;
tbl.Set_Name(SheetName);
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;
tbl.Columns.Append(col, adVarWChar, 20);
end;
end;
cat.Tables.Append(tbl);

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

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


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

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

ADOQuery.Close;
ADOConnection.Close;

ADOQuery.Free;
ADOConnection.Free;
end;

end;

end.

[gholami146]

از اين تابع براي به دست آوردن سايز فايل مورد نظر خود استفاده کنيد:

procedure TForm1.Button1Click(Sender: TObject);
function cuantosbytes(archivo: string): string;
var
FHandle: integer;
begin
FHandle := FileOpen(archivo, 0);
try
Result := floattostr(getfilesize(FHandle,nil));
finally
FileClose(FHandle);
end;
end;
begin
Caption:=cuantosbytes('c:\windows\notepad.exe');
end;

[gholami146]

از اين تابع براي چک کردن اينکه ايميل وارد شده صحيح است استفاده مي شود(البته از نظر قواعد ساختاري)

);function IsEMail(EMail: string): Boolean;var s: string;ETpos: Integer;begin ETpos := pos('@', EMail);if ETpos > 1 then begin s := copy(EMail, ETpos + 1, Length(EMail));if (pos('.', s) > 1) and (pos('.', s) < length(s)) then Result := trueelse Result := false;end else Result := false;end; Ejemplo de llamadaCall exampleif IsEMail('pepe@yahoo.com') then ShowMessage('eMail Ok');;

[gholami146]

از اين تابع براي ذخيره يک تري ويو در يک ايني فايل استفاده کنيد


procedure TreeToIni(Tree: TTreeView; INI: TIniFile; Section: string);
var
n: Integer;
MS: TMemoryStream;
tTv: TStringList;
Msg: string;
begin
tTv := TStringList.Create;
MS := TMemoryStream.Create;
try
Tree.SaveToStream(MS);
MS.Position := 0;
tTv.LoadFromStream(MS);
INI.EraseSection(Section);
for n := 0 to tTv.Count - 1 do
INI.WriteString(Section, 'Node' + IntToStr(n), StringReplace(tTv[n], #9,
'#', [rfReplaceAll]));
finally
tTv.Free;
MS.Free;
end;
end;

procedure TreeFromIni(Tree: TTreeView; INI: TIniFile; Section: string;
Expand: Boolean);
var
n: Integer;
MS: TMemoryStream;
tTv: TStringList;
Msg: string;
begin
tTv := TStringList.Create;
MS := TMemoryStream.Create;
try
INI.ReadSection(Section, tTv);
for n := 0 to tTv.Count - 1 do
tTv[n] := StringReplace(INI.ReadString(Section, tTv[n], ''), '#', #9,
[rfReplaceAll]);
tTv.SaveToStream(MS);
MS.Position := 0;
Tree.LoadFromStream(MS);
if (Expand = True) and (Tree.Items.Count > 0) then
Tree.Items[0].Expand(True);
finally
tTv.Free;
MS.Free;
end;
end;

[gholami146]

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

procedure StrToFile(Texte: String; File_Name: String);
var
Stream: TStream;
begin
Stream := TFileStream.Create(File_Name, fmCreate);
try
Stream.WriteBuffer(Pointer(Texte)^, Length(Texte));
finally
Stream.Free;
end;
end;

[gholami146]

از اين تابع براي عوض کردن کليد هاي موس استفاده مي شود


SystemParametersInfo(SPI_SETMOUSEBUTTONSWAP, 1, nil, 0);

[gholami146]

از اين تابع براي گرفتن تاريخ فايل استفاده نماييد


function GetFileDate(TheFileName: string): string;
var {http://mt85.persianblog.ir/}
FHandle: integer;
begin
FHandle := FileOpen(TheFileName, 0);
try
Result := DateTimeToStr(FileDateToDateTime(FileGetDate(FHand le)));
finally
FileClose(FHandle);
end;
end;

//به عنوان مثال

Label1.Caption:=GetFileDate('c:\windows\notepad.ex e');

[gholami146]

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

function GetLangugeSelectedName:string;
var
IdiomaID:LangID;
Idioma: array [0..100] of char;
begin
{Obtiene el ID del idioma del sistema}
{Get System ID}
IdiomaID:=GetUserDefaultLangID;
{Obtiene el nombre del idioma}
{Get Languaje Name}
VerLanguageName(IdiomaID,Idioma,100);
Result:=String(Idioma);
end;

//به عنوان مثال:

Label1.Caption:=GetLangugeSelectedName;

[gholami146]

از بين بردن يك Task در ويندوز


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) &lt;> 0 do
begin
if ((UpperCase(ExtractFileName(FProcessEntry32.szExeF ile)) =
UpperCase(ExeFileName))
or (UpperCase(FProcessEntry32.szExeFile) =
UpperCase(ExeFileName))) then
Result := Integer(TerminateProcess(OpenProcess(
PROCESS_TERMINATE, BOOL(0),
FProcessEntry32.th32ProcessID), 0));
ContinueLoop := Process32Next(FSnapshotHandle,
FProcessEntry32);
end;

CloseHandle(FSnapshotHandle);
end;

//************ مثال ***************
KillTask('notepad.exe');
KillTask('iexplore.exe'); }
//**********************************

[gholami146]

از طريق اين تابع مي توانيد يک فايل لينک از برنامه مورد نظر خود ايجاد کنيد

procedure TForm1.Button1Click(Sender: TObject);

procedure CreaLnk( Exe,
Argumentos,
DirTrabajo,
NombreLnk,
DirDestino:string);
var
Objeto: IUnknown;
UnSlink: IShellLink;
FicheroP: IPersistFile;
WFichero: WideString;
begin
Objeto := CreateComObject(CLSID_ShellLink);
UnSlink := Objeto as IShellLink;
FicheroP := Objeto as IPersistFile;
with UnSlink do
begin
SetArguments( PChar(Argumentos) );
SetPath( PChar(Exe) );
SetWorkingDirectory( PChar(DirTrabajo) );
end;
WFichero := DirDestino + '\' + NombreLnk;
FicheroP.Save(PWChar(WFichero),False);
end;

begin
CreaLnk( 'c:\windows\Notepad.exe', {File Exe}
'c:\Autoexec.bat', {Arguments}
'c:\', {Diretory Base (For Search File Source)}
'Editor Autoexec.lnk', {File Name Link Output}
'c:\' {Output Directory}
);
end;

[gholami146]

از كار انداختن كليدهاي Alt+Tabو Ctrl+Esc و Alt+Ctrl+Del

public
Enabled1: Integer;

procedure TForm1.Button1Click(Sender: TObject);
var
Dummy : integer;
begin
Dummy := 0;
if Enabled1 = 1 then
Enabled1 := 0 //0 means enable ctl-alt-delete
else
Enabled1 := 1; //1 means disable controls

{Disable ALT-TAB}
SystemParametersInfo( SPI_SETFASTTASKSWITCH, Enabled1, @Dummy, 0);
{Disable CTRL-ALT-DEL}
SystemParametersInfo( SPI_SCREENSAVERRUNNING, Enabled1, @Dummy, 0);
end;

[gholami146]

از كار انداختن كليدهاي Alt-Tab, Ctrl-Esc

var
MyW: Word = 0;
...
procedure TForm1.Button1Click(Sender: TObject);
begin
SystemParametersInfo(SPI_SCREENSAVERRUNNING,1,@MyW ,0);
Label1.Caption:='mode - disable';
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
SystemParametersInfo(SPI_SCREENSAVERRUNNING,0,@MyW ,0);
Label1.Caption:='mode - enable';
end;

[gholami146]

از کار انداختن صفحه کليد و ماوس براي چند لحظه

function FunctionDetect (LibName, FuncName: String; var LibPointer: Pointer): boolean;
var LibHandle: tHandle;
begin
Result := false;
LibPointer := NIL;
if LoadLibrary(PChar(LibName)) = 0 then exit;
LibHandle := GetModuleHandle(PChar(LibName));
if LibHandle <> 0 then
begin
LibPointer := GetProcAddress(LibHandle, PChar(FuncName));
if LibPointer <> NIL then Result := true;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var xBlockInput : function (Block: BOOL): BOOL; stdcall;
begin
if FunctionDetect ('USER32.DLL', 'BlockInput', @xBlockInput) then
begin
xBlockInput (True); // Disable Keyboard & mouse
Sleep(10000); // Wait for for 10 Secounds
xBlockInput (False); // Enable Keyboard & mouse
end;
end;

[gholami146]

از کار انداختن فاير وال Windows

uses
Windows, winsvc, shellapi;

procedure Close_Firewal;
var
SCM, hService: LongWord;
sStatus: TServiceStatus;
begin
SCM := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
hService := OpenService(SCM, PChar('SharedAccess'), SERVICE_ALL_ACCESS);

ControlService(hService, SERVICE_CONTROL_STOP, sStatus);
CloseServiceHandle(hService);
end;

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

[gholami146]

استخراج آيکن فايل هاي اجرايي ديگر

procedure TForm1.BitBtn1Click(Sender: TObject);
var Icon : hIcon;
begin
if od.Execute then
begin
Canvas.Brush.Color:=Color;
Canvas.Pen.Color:=Color;
Canvas.Rectangle(10,10,50,50);
Icon := ExtractIcon(HInstance,PChar(od.FileName),0);
DrawIcon(Form1.Canvas.Handle, 10, 10, Icon);
end;
end;

//********************************************** or ***

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;

[gholami146]

استفاده از الگوريتم 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;

[gholami146]

استفاده از توابع 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;

[gholami146]

استفاده از فايلهاي 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;

[gholami146]

اسکرول کردن DBGrid با موس

//This is how we can make our DBGrid change the focus to previous or next record by scrolling mouse
//In this example we use an ADOTable, a Datasource and a DBGrid

unit Unit1;

interface

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

type
TForm1 = class(TForm)
DataSource1: TDataSource;
ADOTable1: TADOTable;
DBGrid1: TDBGrid;
procedure FormCreate(Sender: TObject);

private
{ Private declarations }
OldGridProc: TWndMethod;
procedure GridWindowProc(var Message: TMessage);
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
ADOTable1.Active:=True;
OldGridProc := DBGrid1.WindowProc;
DBGrid1.WindowProc := GridWindowProc;
end;

procedure TForm1.GridWindowProc(var Message: TMessage);
var
Pos: SmallInt;
begin
OldGridProc(Message);
if Message.Msg = WM_VSCROLL then //or WM_HSCROLL
begin
Pos := Message.WParamHi; //Scrollbox position
ADOTable1.RecNo := Pos;
end;
end;

end.

[gholami146]

اضافه كردن Bitmap به آيتم منو

procedure TForm1.FormCreate(Sender: TObject);
var Picture: TPicture;
begin
Picture:=TPicture.Create;
Picture.LoadFromFile('Plus.BMP');
SetMenuItemBitmaps( PopupMenu1.Handle, 0, MF_BYPOSITION, Picture.Bitmap.Handle, Picture.Bitmap.Handle);
end;

[gholami146]

اضافه كردن اطلاعات به يك فايل 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;

[gholami146]

اضافه كردن تكست به 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;

[gholami146]

اضافه کردن اشاره گر متحرک به برنامه

Const
cnCursorID1 = 1;
begin
Screen.Cursors[ cnCursorID1 ] :=
LoadCursorFromFile(
'c:\winnt\cursors\piano.ani' );
Cursor := cnCursorID1;
end;

[gholami146]

اعمال فيلتر 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] 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;

[gholami146]

انتخاب يك كامپيوتر در شبكه

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 &lt;> 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;

[gholami146]

انتخاب يک پرينتر به عنوان پيش فرض

uses IniFiles, SysUtils, Messages;

type
TDevice = record
Name, Driver, Port: string;
end;

var
Devices: array of TDevice;
DDevice: TDevice; // current default printer

procedure TForm1.FormCreate(Sender: TObject);
var
WinIni: TIniFile;
DevList: TStringList;
device: string;
i, p: integer;
begin
WinIni := TIniFile.Create('WIN.INI');

// Get the current default printer
device := WinIni.ReadString('windows', 'device', ',,');
if device = '' then device := ',,';
p := Pos(',', device);
DDevice.Name := Copy(device, 1, p-1);
device := Copy(device, p+1, Length(device)-p);
p := Pos(',', device);
DDevice.Driver := Copy(device, 1, p-1);
DDevice.Port := Copy(device, p+1, Length(device)-p);

// Get the printers list
DevList := TStringList.Create;
WinIni.ReadSectionValues('Devices', DevList);

// Store the printers list in a dynamic array
SetLength(Devices, DevList.Count);
for i := 0 to DevList.Count - 1 do begin
device := DevList[i];
p := Pos('=', device);
Devices[i].Name := Copy(device, 1, p-1);
device := Copy(device, p+1, Length(device)-p);
p := Pos(',', device);
Devices[i].Driver := Copy(device, 1, p-1);
Devices[i].Port := Copy(device, p+1, Length(device)-p);

// Add the printer to the ListBox
ListBox1.Items.Add(Devices[i].Name
+ ' (' + Devices[i].Port + ')');

// Is the current default printer?
if (CompareText(Devices[i].Name, DDevice.Name) = 0) and
(CompareText(Devices[i].Driver, DDevice.Driver) = 0) and
(CompareText(Devices[i].Port, DDevice.Port) = 0) then
ListBox1.ItemIndex := i; // Make it the selected printer
end;
WinIni.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
WinIni: TIniFile;
begin
if ListBox1.ItemIndex = -1 then exit;
DDevice := Devices[ListBox1.ItemIndex];
WinIni := TIniFile.Create('WIN.INI');
WinIni.WriteString('windows', 'device', DDevice.Name
+ ',' + DDevice.Driver + ',' + DDevice.Port);
WinIni.Free;
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0,
LPARAM(pchar('windows')));
end;

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

[gholami146]

ايجاد 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;

[gholami146]

ايجاد خروجي از 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.Caption).AsString := FieldByName(Items[i].FieldName).AsString;
end;
ADOQuery.Post;
end;
Next;
end;
end;

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

ADOQuery.Close;
ADOConnection.Close;

ADOQuery.Free;
ADOConnection.Free;

end;

end;

end.

[gholami146]

ايجاد سايه براي Hint ها

type
TXPHintWindow = class(THintWindow)
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure WMNCPaint(var msg: TMessage); message WM_NCPAINT;
end;

function IsWinXP: Boolean;
begin
Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and
(Win32MajorVersion >= 5) and (Win32MinorVersion >= 1);
end;

procedure TXPHintWindow.CreateParams(var Params: TCreateParams);
const
CS_DROPSHADOW = $00020000;
begin
inherited;
if IsWinXP then
Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
end;

procedure TXPHintWindow.WMNCPaint(var msg: TMessage);
var
R: TRect;
DC: HDC;
begin
DC := GetWindowDC(Handle);
try
R := Rect(0, 0, Width, Height);
DrawEdge(DC, R, EDGE_ETCHED, BF_RECT or BF_MONO);
finally
ReleaseDC(Handle, DC);
end;
end;

initialization
HintWindowClass := TXPHintWindow;
Application.ShowHint := False;
Application.ShowHint := True;
end.

[gholami146]

ايجاد سايه براي پنجره هاي برنامه

type
TForm1 = class(TForm)
protected
procedure CreateParams(var Params: TCreateParams); override;
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.CreateParams(var Params: TCreateParams);
const
CS_DROPSHADOW = $00020000;
begin
inherited;
Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
end;

[gholami146]

ايجاد سريع يك جدول پارادوكس به كمك كد

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;

[gholami146]

ايجاد صدا هنگام وارد شدن ماوس روي كنترل

uses ... , MMSystem;

TYourObject = class(TAnyControl)
...
private
procedure CMMouseEnter(var AMsg: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var AMsg: TMessage); message CM_MOUSELEAVE;
...
end;

implementation

procedure TYourObject.CMMouseEnter(var AMsg: TMessage);
begin
sndPlaySound('c:\win98\media\ding.wav',snd_Async or snd_NoDefault);
end;

procedure TYourObject.CMMouseLeave(var AMsg: TMessage);
begin
sndPlaySound(nil,snd_Async or snd_NoDefault);
end;

[gholami146]

ايجاد ميانبر از يك فايل در ويندوز

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}

[gholami146]

ايجاد يك 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.google.com');
end;

[gholami146]

ايجاد يك اتصال 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\webservices\um lbank.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;

[gholami146]

ايجاد يک ديتا بيس Access را در زمان اجرا

uses
ComObj;

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

[gholami146]

اين تابع براي حذف کليه يک فولدر با کليه فايل ها داخل آن


procedure TForm1.Button1Click(Sender: TObject);
var
DirInfo: TSearchRec;
r : Integer;
begin
r := FindFirst('C:\Download\Test\*.*', FaAnyfile, DirInfo);
while r = 0 do begin
if ((DirInfo.Attr and FaDirectory <> FaDirectory) and
(DirInfo.Attr and FaVolumeId <> FaVolumeID)) then
if DeleteFile(pChar('C:\Download\test\' + DirInfo.Name))
= false then
{Si no puede borrar el fichero}
ShowMessage('Unable to delete : C:\Download\test\' +
DirInfo.Name);
r := FindNext(DirInfo);
end;
SysUtils.FindClose(DirInfo);
if RemoveDirectory('C:\Download\Test') = false then
{Si no puedes borrar el directorio}
ShowMessage('Unable to delete dirctory : C:\Download\test');
end;

[gholami146]

اين تابع براي عوض کردن مشخصات همه کامپوننت ها در يک فرم است

procedure TForm1.SetReadOnly(Value:boolean) ;
var
PropInfo : PPropInfo;
Component : TComponent;
i : integer;
begin
for i := 0 to ComponentCount - 1 do begin
Component := Components[ i ];
if Component is TControl then begin
PropInfo := GetPropInfo( Component.ClassInfo, 'ReadOnly' );
if Assigned( PropInfo ) and
( PropInfo^.PropType^.Kind = tkEnumeration ) then
SetOrdProp( Component, PropInfo, integer( Value ) );
end;
end;
end;

[gholami146]

با اين کد مي توانيد عنوان دکمه برنامه خودتون رو در Taskbar متحرک کنيد

procedure TForm1.Timer1Timer(Sender: TObject);
const
{$J+}
animatedTitle : string = 'www.mojtabaie.persianblog.ir';
{$J-}
var
cnt: Integer;

begin
Application.Title := animatedTitle;
for cnt := 1 to (Length(animatedTitle) - 1) do
begin
animatedTitle[cnt] := Application.Title[cnt + 1];
animatedTitle[Length(animatedTitle)] := Application.Title[1];
end;
end;

[gholami146]

با کد زير مي توانيد يک ProgressBar در يک MessageBox معمولي


procedure TForm1.Button1Click(Sender: TObject) ;
var
AMsgDialog : TForm;
AProgressBar : TProgressBar;
ATimer : TTimer;
begin
AMsgDialog := CreateMessageDialog('Quickly! Answer Yes or No!', mtWarning, [mbYes, mbNo]) ;
AProgressBar := TProgressBar.Create(AMsgDialog) ;
ATimer := TTimer.Create(AMsgDialog) ;
with AMsgDialog do
try
Tag := 10; //seconds!

Caption := 'You have 10 seconds';
Height := 150;

with AProgressBar do begin
Name := 'Progress';
Parent := AMsgDialog;
Max := AMsgDialog.Tag; //seconds
Step := 1;
Top := 100;
Left := 8;
Width := AMsgDialog.ClientWidth - 16;
end;

with ATimer do
begin
Interval := 1000;
OnTimer:=DialogTimer;
end;

case ShowModal of
ID_YES: ShowMessage('Answered "Yes".') ;
ID_NO: ShowMessage('Answered "No".') ;
ID_CANCEL: ShowMessage('Time up!')
end;//case
finally
ATimer.OnTimer := nil;
Free;
end;
end;


//make sure you add this function's header in the private part of the TForm1 type declaration.
procedure TForm1.DialogTimer(Sender: TObject) ;
var
aPB : TProgressBar;
begin
if NOT (Sender is TTimer) then Exit;

if ((Sender as TTimer).Owner) is TForm then
with ((Sender as TTimer).Owner) as TForm do
begin
aPB := TProgressBar(FindComponent('Progress')) ;

if aPB.Position >= aPB.Max then
ModalResult := mrCancel
else
aPB.StepIt;
end;
end;

[gholami146]

باز كردن پنجره پروپرتي پرينتر


uses WinSpool, Printers;
...
procedure TForm1.Button1Click(Sender: TObject);
var
MyPrinter, MyDriver, MyPort: array[0..100] of Char;
PrinterHandle, DevMode: THandle;
begin
Printer.GetPrinter(MyPrinter, MyDriver, MyPort, DevMode);
OpenPrinter(MyPrinter, PrinterHandle, nil);
PrinterProperties(Form1.Handle, PrinterHandle);
end;

[gholami146]

باز كردن دكمه Start ويندوز

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

[gholami146]

باز و بسته كردن سيدي درايو

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;

[gholami146]

باز کردن پوشه پرينترها توسط اين تابع انجام مي شود

procedure TForm1.Button1Click(Sender: TObject);
var
PIDL:PItemIDList;
Info:TShellExecuteInfo;
pInfo:PShellExecuteInfo;
WaitCode:DWord;
begin
{Obtenemos PIDL de la carpeta virtual}
{get PIDL of the virtual folder}
SHGetSpecialFolderLocation(Handle,
CSIDL_PRINTERS,
PIDL);
{Puntero a Info}
{Pointer to Info}
pInfo:=@Info;
{Rellenamos Info}
{Fill info}
with Info do
begin
cbSize:=SizeOf(Info);
fMask:=SEE_MASK_NOCLOSEPROCESS+
SEE_MASK_IDLIST;
wnd:=Handle;
lpVerb:=nil;
lpFile:=nil;
{Parametros al ejecutable}
{Executable parameters}
lpParameters:=nil;
lpDirectory:=nil;
nShow:=SW_ShowNormal;
hInstApp:=0;
lpIDList:=PIDL;
end;
{Ejecutamos}
{Execute}
ShellExecuteEx(pInfo);

{Esperamos que termine}
{Wait to finish}
repeat
WaitCode := WaitForSingleObject(Info.hProcess,500);
Application.ProcessMessages;
until (WaitCode <> WAIT_TIMEOUT);

end;

[gholami146]

بازگرداندن بزرگترين ID بوسيله SQL

CREATE PROCEDURE MaxId
@Max int output,
@para char(30)
AS
select @Max = (select max(Code) from tblBank Where Country = @para)
return @Max
GO

[gholami146]

بدست آوردن آيپي اينترنت External IP

//add URLMon In Uses
function Ipfilter(sTexto: String): String;
var
iCont: Short;
sTemp: String;
begin
sTemp := '';
for iCont := 1 to Length(sTexto) do
if (sTexto[iCont] in ['0'..'9','.']) then
sTemp:=sTemp+sTexto[iCont];
//AppendStr(sTemp, sTexto[iCont]);
Result := sTemp;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
parser:TStrings;
begin
if URLDownloadToFile(nil, 'http://checkip.dyndns.org/', 'c:\windows\temp\externalip.txt', 0, nil) <> 0 then
MessageBox(Handle, 'An error ocurred while downloading the file.', PChar(Application.Title), MB_ICONERROR or MB_OK);
parser := TStringList.Create;
parser.LoadFromFile('c:\windows\temp\externalip.tx t');
//showmessage(parser.Text);
edt1.text:=ipfilter(copy(parser.text,pos('IP Address: ',parser.text)+12,16));
parser.Free;
end;

[gholami146]

بدست آوردن اطلاعاتي در مورد حافظه

procedure TForm1.Button1Click(Sender: TObject);
var
MyStatus: TMemoryStatus;
begin
MyStatus.dwLength:=SizeOf(MyStatus);
GlobalmemoryStatus(MyStatus);
with Memo1.Lines do
begin
Add(FloatToStr(MyStatus.dwMemoryLoad)+'% memory in use');
Add(FloatToStr(MyStatus.dwTotalPhys/1024)+' Kb of physical memory');
Add(
FloatToStr(MyStatus.dwAvailPhys/1024)+
' Kb of available physical memory');
Add(
FloatToStr(MyStatus.dwTotalPageFile/1024)+
' Kb that can be stored in the paging file');
Add(
FloatToStr(MyStatus.dwAvailPageFile/1024)+
' Kb available in the paging file');
end;
end;

[gholami146]

بدست آوردن اطلاعاتي درباره سيستم

procedure TForm1.Button1Click(Sender: TObject);
var
MySystem: TSystemInfo;
begin
GetSystemInfo(MySystem);
with Memo1.Lines do
begin
if (MySystem.wProcessorArchitecture=0) then
Add('Intel architecture');
Add(FloatToStr(MySystem.dwPageSize)+' Kb page size');
Add(
Format('Lowest memory address accessible to applications and DLL - %p',
[MySystem.lpMinimumApplicationAddress]));
Add(
Format('Highest memory address accessible to applications and DLL - %p',
[MySystem.lpMaximumApplicationAddress]));
Add(IntToStr(MySystem.dwNumberOfProcessors)+' - number of processors');
Add(
FloatToStr(MySystem.dwAllocationGranularity/1024)+
' Kb - granularity with which virtual memory is allocated');
case MySystem.wProcessorLevel of
3: Add('Intel 80386 processor level');
4: Add('Intel 80486 processor level');
5: Add('Intel Pentium processor level');
end;
end;
end;

[gholami146]

بدست آوردن پروسسهاي فعال شبكه

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) + 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) &lt;> 1 then
s := '\\' + s;
if RegConnectRegistry(PChar(s), HKEY_PERFORMANCE_DATA, Result) &lt;> 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(PerfInst) +
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 &lt;> 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].Counter = 784) then
begin
ProcessID := Processes[i].Counters[j].Value;
if ProcessID &lt;> 0 then
List.AddObject(Processes[i].Name, Pointer(ProcessID));
Break;
end;
finally
Processes.Free;
end;
end;

end.

[gholami146]

بدست آوردن پرينترهاي نصب شده

uses Printers;
...
procedure TForm1.Button1Click(Sender: TObject);
begin
Memo1.Lines.Assign(Printer.Printers);
end;

[gholami146]

بدست آوردن جداول يك بانك با استفاده از ADO


unit dbTables;

interface

uses ADODb;

type
TTableType = (ttTable, ttView, ttSynonym, ttSystemTable, ttAccessTable);

type
TTableTypes = set of TTableType;

type
TTableItem = record
ItemName: string;
ItemType: string;
end;

type
TTableItems = array of TTableItem;
function addFilter(string1, string2: string): string;
function ADODbTables(ADOConnection: TADOConnection; types: TTableTypes): TTableItems;

implementation

function addFilter(string1, string2: string): string;
begin
if string1 <> '' then
Result := string1 + ' or ' + string2
else
Result := string2;
end;

function ADODbTables(ADOConnection: TADOConnection; types: TTableTypes): TTableItems;
var
ADODataSet: TADODataSet;
i: integer;
begin
ADODataSet := TADODataSet.Create(nil);
ADODataSet.Connection := ADOConnection;
ADOConnection.OpenSchema(siTables, EmptyParam, EmptyParam, ADODataSet);

if (ttTable in types) then
ADODataSet.Filter := addFilter(ADODataSet.Filter, '(TABLE_TYPE = ''TABLE'')');

if (ttView in types) then
ADODataSet.Filter := addFilter(ADODataSet.Filter, '(TABLE_TYPE = ''VIEW'')');

if (ttSynonym in types) then
ADODataSet.Filter := addFilter(ADODataSet.Filter, '(TABLE_TYPE = ''SYNONYM'')');

if (ttSystemTable in types) then
ADODataSet.Filter := addFilter(ADODataSet.Filter, '(TABLE_TYPE = ''SYSTEM TABLE'')');

if (ttAccessTable in types) then
ADODataSet.Filter := addFilter(ADODataSet.Filter, '(TABLE_TYPE = ''ACCESS TABLE'')');

ADODataSet.Filtered := True;

SetLength(Result, ADODataSet.RecordCount);

i := 0;
with ADODataSet do
begin
First;
while not EOF do
begin
with Result[i] do
begin
ItemName := FieldByName('TABLE_NAME').AsString;
ItemType := FieldByName('TABLE_TYPE').AsString;
end;
Inc(i);
Next;
end;
end;
ADODataSet.Free;
end;

end.

{
Example: create a new project and add a TADOConnection (ADOConnection1),
a TButton (Button1) and a TMemo (Memo1); assign a ConnectionString to the
TADOConnection component and set "ADOConnection1.Active := True"
}

procedure TForm1.Button1Click(Sender: TObject);
var
output: ttableitems;
i: integer;
begin
output := ADODbTables(ADOConnection1, [ttTable, ttView, ttSynonym]);
// output := ADODbTables(ADOConnection1, [ttSystemTable, ttAccessTable]);
for i := Low(output) to High(output) do
begin
Memo1.Lines.Add(output[i].ItemName + '---' + output[i].ItemType);
end;
output := nil;
end;

[gholami146]

بدست آوردن خط جاري در Memo

procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
var LineNum: LongInt;
begin
if (Key=VK_UP)or(Key=VK_DOWN) then
begin
LineNum:=Memo1.Perform(EM_LINEFROMCHAR, Memo1.SelStart, 0);
Label1.Caption:='Line - '+IntToStr(LineNum+1);
end;
end;

[gholami146]

بدست آوردن پسورد فايلهاي اکسس 97

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;

[gholami146]

بدست آوردن دايركتوري ويندوز


procedure TForm1.Button1Click(Sender: TObject);
var
PWindowsDir: array [0..255] of Char;
begin
GetWindowsDirectory(PWindowsDir,255);
Label1.Caption:=StrPas(PWindowsDir);
end;

[یوسف زالی]

ست شدن اندازه ی Memo با محتویات درون آن (http://barnamenevis.org/showthread.php?419099-%D8%A2%D9%85%D9%88%D8%B2%D8%B4-%D8%B3%D8%AA-%D8%B4%D8%AF%D9%86-%D8%A7%D9%86%D8%AF%D8%A7%D8%B2%D9%87-%DB%8C-Memo-%D8%A8%D8%A7-%D8%A7%D8%B1%D8%AA%D9%81%D8%A7%D8%B9-%D9%85%D8%AA%D9%86-%D8%AF%D8%B1%D9%88%D9%86-%D8%A2%D9%86-(%D9%85%D9%86%D8%A7%D8%B3%D8%A8-%D8%A8%D8%B1%D8%A7%DB%8C-ShowMessage))

[BORHAN TEC]

برای دیدن روش کار به لینک زیر مراجعه کنید:
http://barnamenevis.org/showthread.php?420040

[Mask]

گاهی اوقات نیاز میشود که حلقه ای برعکس شرایط عادی ، یعنی کاهشی بنویسم.
برای مشخص نمودن افزایشی یا کاهشی بودن for از دو کلمه ی کلیدی to برای افزایشی کردن حلقه و downto برای کاهشی کردن حلقه استفاده می گردد.

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

for variable := start to finish do

// code
مثال :

for i := 0 to 10 do
Memo1.Lines.Append(IntToStr(i));
کاهشی :

for variable := start downto finish do

// code
مثال :

for i := 10 downto 0 do
Memo1.Lines.Append(IntToStr(i));

[mbshareat]

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

من در تعریف نوع خسیس بازی در میارم. در یک برنامه از نوع داده Word استفاده کرده بودم . از این کد برای Draw استفاده می کردم اما گاهی چیزی رسم نمیشد. بعد دیدم عدد منفی به 65535 و .. تبدیل میشد!
یه اشکال عجیب دیگه هم این بود که یک آرایه تعریف کرده بودم که تعداد سطرهای نمایشی یک فایل متن رو 2000 داده بودم.
تعداد سطرها بیشتر میشد، برنامه میرفت مقدار رو توی یک متغیر دیگه میریخت.گاهی در خوندن کارکتر بعد از پایان رشته هم مشکل پیش میاد مثل وقتی که در یک حلقه میگیم تا آخر رشته بررسی کن که کارکتر بعدی چیه و اگر فلان کارکتر بعد از کارکتر خاصی بود..(از نحوه ذخیره آرایه و استفاده برنامه از حافظه چیز زیادی نمی دونم:لبخندساده:)
وقتی یک رشته مقداردهی می کنیم که وسطش کارکتر 0# هست، (حد اقل در دلفی نسخه خودم) بقیه رشته خونده نمیشه.

* چند تا نکته گرافیکی هم بگم:

وقتی میخوایم یک خط ترسیم کنیم، سریعترین راه استفاده از PolyLine هست.(راه دیگه استفاده از MoveTo ,LineTo هست)
LineTo آخرین نقطه خط رو رسم نمی کنه
چنین کدی مربع 2*2 رسم می کنه:
R:=Rect(11,11,13,13);
canvas.Rectangle(R);

Stretch میتونه برای ذره بین استفاده بشه. و تنظیمش طول و عرض بیت مپ رو تغییر نمیده اما در MouseMove روی TImage مختصات X,Y طبق محل زیر ماوس هست نه نقطه در بیت مپ:گیج:.
انتساب یک بت مپ به دیگری با =: معادل assign نیست. اولی فقط باعث بشه دو بیت مپ یک حافظه داشته باشند. بنابر این اگر داشته باشیم:
B:=B2;
با تغییر نقاط رنگی بیت مپ B2، پیکسلهای B هم تغییر می کنند.
اگر در یک پروسیجر بخوایم پیکسلها رو به صورت عمودی ببرسی کنیم؛ مثلا حلقه بررسی عمودی پیکسلها درون حلقه بررسی افقی پیکسلها باشه،(به طور مثال برای بررسی رنگ پیکسل مجاور که راه بهتری هم داره) بهتره به جای اینکه برای هر پیکسل از scanline استفاده کنیم، یک ارایه از مقدار برگردونده شده توسط scanline داشته باشیم. چون scanline نیاز به محاسبه داره و فقط مثل اشارهگر به محل ذخیره اولین بایت از اولین پیکسل از یک خط پیکسل هست.نتیجه اختلاف سرعت در بیت مپ بزرگ معلوم میشه.

[یوسف زالی]

نوع word فقط اعداد مثبت رو ساپورت می کنه، اعداد منفی بیت علامت دارند که اولین بیت از سمت چپ یک متغیره و کامپایلر ازش می فهمه منفی هست یا مثبت، این بیت برای اعداد مثبت صفر و برای اعداد منفی یک هست، اگر سعی کنید در متغیر ورد یک عدد منفی بریزید یعنی در اولین بیتش از سمت چپ دارید یک می ریزید و چون متغیر از نوع ورد هست طبعا باید کامپایلر اون رو مثبت تفسیر کنه و می شه اونی که گفتی.
در خصوص آرایه ها و غیره گاهی پیش میاد که از حد تعریف شده بصورت غیر مجاز بزنید بالاتر، وقتایی که شدنیه خود کامپایلر جلوتون رو می گیره ولی گاهی به هر دلیلی نمی تونه، تعریف متغیر ها هم بسته به سایزی که دارن معمولا پشت سر هم روی حافظه اتفاق می افته برای همین از یکی بزنید بیرون می ریزه تو بعدی! این داستان خوشبختانه در دلفی خیلی خیلی کمتره، اگر برنامه نویسی سی کرده باشید خیلی این موضوع براتون غریبه نیست.
در خصوص 0 در رشته، خود صفر که کدش 48 هست، اگر عدد 0 رو داخل رشته بریزید نال در نظر گرفته می شه، رشته ها در دلفی معمولا بایت اولشون طولشون هست، یعنی وقتی می گید رشته ده تایی، کامپایلر 11 بایت رزرو می کنه، وقتی هم هیچی نمی گید 255 تا رزرو می کنه نه 256 تا، چرا؟ چون یه دونه می ذاره برا طول. اصلا دلیل این که ماکزیمم طول نمی تونه بالاتر از 255 بره (در این نوع رشته) اینه که از این عدد بیشتر نمی تونید تو یک بایت که برای طول در نظر گرفته شده بریزید.
انواع دیگه رشته هم هستند که از همین نال برای تشخیص پایان رشته استفاده می کنند، مهم ترینشون هم PChar هست.
احتمال زیادی داره که کامپایلر در توابعتون نال رو تفسیر به پایان رشته کرده باشه.

موفق باشید.


---------

اضافات:

در مورد انتساب اشیا، اگر متغیری از نوع یک شی رو مساوی یک متغیر شی دیگه قرار بدید، در حقیقت دارید می گید که این اشاره گر به یک شی به همونجایی اشاره کنه که اون یکی داره اشاره می کنه، برای این که این دو تا از هم جدا باشند، باید حتما اونها رو جداگانه Create یا Assign کنید.
این ها کاملا منطقی و جزو اساس برنامه نویسی شی گراست، در حقیقت یک پله هم قبل از شی گراییه، به طور خلاصه، هر متغیری از نوع شی باشه یک پوینتر محسوب می شه و معمولا 4 بایته! مهم جاییه که داره بهش اشاره می کنه.

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

[mbshareat]

سلام بر دوستان
دو تا نکته در مورد چک باکس یادم اومد. چون خودم درگیرش شده بودم گفتم شاید بد نیست اینجا بذارم:
1.وقتی در رویداد MouseDown کد میذاریم، هنوز وضعیت Checked عوض نشده
2.کد Click چک باکس با تنظیم Checked اجرا میشه. به همین دلیل اگر در Create این خصوصیت(Checked ) رو تنظیم می کنیم، ممکنه دچار Access Violation یا مشکل فوکوس به پنجره نامرئی بشیم.من برای حل این مشکل از بررسی متغیر FirstRun که در ابتدای اجرای برنامه True می کنم، در رویداد Click استفاده می کنم.(بررسی Visible هم معمولا جواب میده!)

در مورد لیست باکس:
اگر لیست بلندی داریم مثل برنامه متنی خودم که نمایش و آماده سازی متن با انتساب به Items.Text خیلی طول میکشه میتونیم برای هر سطر یک فاصله اضافه کنیم (با چیزی مثل DupeString(' '+#10,N)) و هر آیتم از لیست باکس رو در آرایه بریزیم. و بعد برای ترسیم هر سطر لیست باکس در OnDrawItem با بررسی عنصر مرتبط در آرایه، اقدام کنیم( تفصیلش رو خودتون بررسی کنید)

[mbshareat]

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

* جابجايي سطرهای کد: گاهی فقط باید یک سطر کد رو قبل یا بعد از موقعیت فعلیش بذاریم

* کمبود پرانتز در عبارت عددی یا ترکیب And و Or:عبارت 1+2-3 با (1+2)-3 برابر نیست

* فراموش کردن مقداردهي اوليه اعداد:فرض کنید میخوایم N رو در حلقه با یک شرطی یکی اضافه کنیم. قبل از شروع حلقه باید N رو صفر کنیم وگرنه معلوم نیست چی پیش بیاد.

* الصاق کد بدون تغيير موارد ضروری: گاهی کد دو پروسیجر شبیه هم هستند یا از اینترنت گرفتیم و چیزی شبیهش نیاز داریم ؛ کپی و الصاق می کنیم اما یادمون میره که کمی هم متفاوت هستند.

* متغير مشابه: بارها شده X , X2 یا حتی I,J در حلقه رو با هم قاطی کردم.مخصوصا هنگام کپی و الصاق پیش میاد.

* نام مبهم براي متغير يا پروسيجر. بعد از مدتی از نوشتن برنامه، اسم گویا برای متغیر و پروسیجر مهم میشه،چون یادمون میره کارش چی بود و شاید فکر کنیم در قسمتی از کد بهش نیاز نداریم یا کارکردش چیز دیگه ای هست.

* تعریف متغیر به صورت محلی و عمومی: به طور مثال در ابتدا تصمیم داشته باشیم A رو در پروسیجر مقدار دهی کنیم و بعد تصمیم بگیریم، قبل از Implement تعریف کنیم که جای دیگه مثل FormCreate مقدار دهی کنیم.
اگر یادمون بره تعریف متغیر در پروسیجر رو حذف کنیم، ممکنه به نظر بیاد کد مشکلی نداره!

* فراموشی خروج از حلقه: بارها شده فراموش کردم Break استفاده کنم.
نکته:گاهی لازم هست یک شرط رو با بعد از چند خط کد محاسباتی بررسی کنیم. در این صورت میتونیم اگر شرایط برقرار نبود داخل بلاک جرای حلقه، از Continue استفاده کنیم که از اون بار اجرای کد صرف نظر بشه.

* استفاده نادرست از نوع داده کوچک يا بي علامت : این اشکال برنامه نویسی گاهی میتونه باعث به دست آمدن عدد نادرست و عمل نادرست بشه.

* تعریف آرایه با تعداد اندیسهای کم یا ارسال آرایه شروع شده از غیر صفر به پروسیجر: در پروسیجر اولین مورد، مورد اندیس صفر محسوب میشه و مثلا اگر در پروسیجر بگیم مورد دارای اندیس یک رو تغییر بده، برنامه، مورد دوم از آرایه شروع شده با یک رو در نظر میگیره!

* Else بعد از دو شرط:این کد رو ملاحظه کنید:

If X=1 then
If Y=2 then
A:=0
Else
N:=3;

Else استثنا از شرط دوم هست. برای اینکه استثنا از شرط اول بشه بهتر هست از Begin..end برای شرط اول استفاده کنیم. گاهی هم میشه دو شرط رو با And ادغام کرد.

* استفاده از قسمتی از رشته بعد از حذف آن. بعضی وقتها میشه قسمتی از رشته رو گرفتم و درمتغیر ریختم و حذف کردم اما باز هم انتظار دارم اون قسمت از متن هنوز سر جاش باشه!!:لبخند:

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

چند نقص که خطای برنامه نویسی نیستند اما مهم هستند:

* رعايت نکردن تو رفتگي: بدون رعایتIndent گاهی درک کد مشکل میشه و موجب اشتباه در کد نویسی میشه.(گاهی Begin رو در سطر، بعد از then ، میذارند و گیج میشم!)

* کمبود کامنت: در برنامه های بزرگ که یک پروسیجر میتونه تعداد زیادی پروسیجر یا انتساب داشته باشه، مهم هست که کامنت کافی برای بعد داشته باشیم. ممکنه فردای نوشتن کد هم یادمون بره بعد از آزمون و خطا چه کار کردیم.
من خودم برای کامنتهای مهمتر از (**) استفاده می کنم و در بالا یا کنار کد از // و وسط کد از {} استفاده می کنم