تبلیغات تبلیغات
لطفا کمی صبر کنید...
وبلاگ به خاطر حجم بسیار زیاد مطالب کمی سنگین شده است.
شاید بیش از یک دقیقه طول بکشد.
استفاده از مطالب این وبلاگ فقط با ذکر منبع بلامانع میباشد.
| تبادل بنر تبلیغاتی | تبادل لوگوی وبلاگ |
|
کلاسهای آموزش برنامه نویسی :
VB6 - VB.NET - C - C# - ASP - ASP.NET
به صورت خصوصی در مشهد با قیمت جلسه ای 10 هزار تومان - (حرفه ای شوید) کلاسهای آموزش آنتی ویروس نویسی به صورت خصوصی از مقدماتی تا پیشرفته جلسه ای 15 هزار تومان جهت کسب اطلاعات بیشتر با شماره 09364222771 تماس بگیرید |
نظــــر = شخصیّــت
سلام دوستان. خسته نباشید. این برنامه که قرار دادم یک برنامه تحلیلگر عبارت هست که تو تصویر زیر میتونید کارش رو ببینید.
خب همون طور که از تصویر پیداست این برنامه برای به جواب رسوندنه یک عبارت به کار میره. در واقع اگه شما عبارت رو به صورت جمع و تفریق و کلا به صورت عملگر بنویسید، این برنامه اون رو به جواب میرسونه. همون برنامه Prefix و Postfix در درس ساختمان داده که تو دانشگاه میخونیم.
دانلود (حجم : 11 کیلوبایت)
موفق و پیروز باشید.
نظــــر بــــدهید...
سلام دوستان عزیز.
احتمالا تا حالا براتون پیش اومده که برای یک کار خاص مثلا چک کردن وضعیت فایل AUTORUN.INF نیاز داشته باشید که تمامه درایوهای سیستم رو چک کنید. خب چطوری میشه فهمید که چه درایوهایی وجود داره؟
اینجا یک تابع API معرفی میکنیم که کارش همینه (درایوهای منطقی رو برمیگردونه) کافیه به شکلی که در زیر میبینید ازش استفاده کنید.
یک پروژه جدید باز کنید و کدهای زیر رو تو قسمت جنرال فرمتون کپی کنید.
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Sub Form_Load()
Me.AutoRedraw = True
Drives = GetMyLogicalDrives
For i = 0 To UBound(Drives)
Print Drives(i)
Next
End Sub
Public Function GetMyLogicalDrives()
Dim strBuffer As String
strBuffer = String(255, Chr$(0))
ret& = GetLogicalDriveStrings(255, strBuffer)
strBuffer = Replace(strBuffer, Chr(0), " ")
strBuffer = Trim(strBuffer)
strDrives = Split(strBuffer)
GetMyLogicalDrives = strDrives
End Function
تابع GetLogicalDriveStrings در واقع به خودیه خود نامه تمامه درایو ها رو میده اما مشکلش اینه که تمامه حروف رو تو یک رشته بر میگردونه و نام درایو ها رو با NULL جدا میکنه که اینجا برای رفع این مشکل از تابع Split استفاده کردیم و رشته جدا کننده رو NULL قرار دادیم با این کار یک آرایه درست میشه که تو هر خونه نام یک درایو قرار گرفته.
موفق و پیروز باشید.
نظــــر بــــدهید...
سلام دوستان. این برنامه که براتون قرار دادم در واقع یک نرم افزار کاربردی برای مقابله با ویروس ها و رفع خطرات و صدمات ناشی از ویروس هاست. طرز کار این نرم افزار به این صورت هست:
ابتدا باید بدونید که نام ویروس چیه و تحت چه نامی اجرا شده و در قسمت انتخاب پردازش درون برنامه اسمه اون فایل رو انتخاب کنید و کلید تعمیر رو انتخاب کنید. کار کردن باهاش خیلی ساده هست به راحتی میتونید یاد بگیرید. برنامه به صورت خودکار کلیدهای آسیب دیده رجیستری رو تعمیر میکنه و فایل های AUTORUN.INF رو هم پاک میکنه. تنها ایرادی که داره اینه که ویروس رو از تو قسمت Startup خارج نمیکنه و شما باید اینکار رو خودتون انجامش بدین.
دانلود سورس
حجم فایل ۳۲۱۹ کیلوبایتموفق و پیروز باشید.
نظــــر بــــدهید...
سلام دوستان. این ترفندی که امروز میخوام آموزش بدم خیلی جالب و کاربردی هست ولی این ترفند هیچ ارتباطی با برنامه نویسی نداره بلکه به سیستم عامل مربوط میشه.
احتمالا تمام شما دوستان عزیز با نرم افزار USB Disk Security کار کردید و با طرز کارش آشنا هستید و به احتمال 90 درصد ، پوشه AUTORUN.INF که نرم افزار USB Disk Security میسازه رو دیدید. اگه توجه کرده باشید ، درون این پوشه یک پوشه دیگه با نام Zhengbo. قرار داره که به هیچ عنوان پاک نمیشه. تا حالا شده از خودتون بپرسید که این پوشه چرا پاک نمیشه؟ چرا نمیشه واردش شد؟ اصلا چطوری ساخته شده؟ و ....
جواب این سوال اینجاست:
سلام دوستان. این ترفندی که امروز میخوام آموزش بدم خیلی جالب و کاربردی هست ولی این ترفند هیچ ارتباطی با برنامه نویسی نداره بلکه به سیستم عامل مربوط میشه.
احتمالا تمام شما دوستان عزیز با نرم افزار USB Disk Security کار کردید و با طرز کارش آشنا هستید و به احتمال 90 درصد ، پوشه AUTORUN.INF که نرم افزار USB Disk Security میسازه رو دیدید. اگه توجه کرده باشید ، درون این پوشه یک پوشه دیگه با نام Zhengbo. قرار داره که به هیچ عنوان پاک نمیشه. تا حالا شده از خودتون بپرسید که این پوشه چرا پاک نمیشه؟ چرا نمیشه واردش شد؟ اصلا چطوری ساخته شده؟ و ....
جواب این سوال اینجاست:
سیستم عامل به طور پیش فرض تعدادی از اسامی رو که معمولا برای خروجی استفاده میشه رو رزرو کرده و این اسامی رو نمیشه به طور عادی به یک فایل یا پوشه نسبت داد. تعدادی از این اسامی که نامهای غیر مجاز نام دارند عبارت اند از :
AUX , NUL , PRN , CON , COM1 , COM2 ,..., COM9 , LPT1 , LPT2 ,..., LPT9
و از جمله این اسامی میشه به پوشه هایی اشاره کرد که نامشون به . (نقطه) ختم میشه که اسامیه خیلی خیلی غیر مجاز تشریف دارند.
این پوشه ها رو چطوری بسازیم؟
برای ایجاد چنین پوشه های باید از دستوراتی که جهت کار کردن با UNC هست استفاده کنید. به دستور زیر تو جه کنید :
Private Sub Test()
'Create Folder
MkDir "\\.\C:\CON"
MkDir "\\.\C:\AUX"
MkDir "\\.\C:\PRN"
'Delete Folder
RmDir "\\.\C:\CON"
RmDir "\\.\C:\AUX"
RmDir "\\.\C:\PRN"
End Sub
با استفاده از دستور فوق میتونید پوشه های با نام های غیر مجاز ویندوز بسازید.
اما سوال...؟
کاراکترهای \\.\ که قبل از نام درایو نوشته شده چی هست؟
اون کاراکترها همون چیزی هست که قبلا گفتم یعنی برای کار کردن با UNC استفاده میشه. اما مهم نیست که با این کاراکترها آشنا هستید یا خیر، مهم اینه که میتونید با استفاده از این کاراکترها، پوشه هایی با نام های غیر مجاز بسازید.
توجه : اگر با این دستور، پوشه ای با نام غیر مجاز ساختید، دیگه نمیشه اونو پاکش کرد یا تغییر نامش داد مگر با استفاده از همین دستور که داخل قطعه کد بالا نوشتم. شما با استفاده از این ترفند میتونید برنامه ای مشابه با USB Disk Security بسازید یعنی پوشه AUTORUN.INF رو بسازید و داخل اون یک پوشه با نام مثلا CON یا NUL بسازید و به این ترتیب کاربران نمیتونن اون پوشه رو حذف کنند و همچنین از دست ویروس ها هم در امان خواهید بود.
سوال بزرگ...؟
چرا با ان دستور نمیشه پوشه ای ساخت که نامش به . (نقطه) ختم میشه؟
پوشه Zhengbo. که توسط USB Disk Security درون AUTORUN.INFساخته میشه رو چطور باید ساخت یا پاک کرد؟؟؟؟
خوشبختانه من جواب این سوال رو میدونم و در آخرین ورژن ویروسی که نوشتم از این ترفند استفاده کردم.
اما.......
متاسفانه به دلیل رعایت نشدن قانون کپی و رایت در ایران و همچنین استفاده بی رویه وبلاگ نویسان از مطالب دیگران بدون ذکر منبع ، از بیان این ترفند محبوب که سوال خیلی از برنامه نویسان هست، معذورم.
البته شاید در آینده ای نه چندان دور (چند ماه دیگه) که پروژه فارغ التحصیلی رو ارائه دادم، این ترفند محبوب رو هم روی اینترنت قرار بدم. البته اون موقع هم فقط به شرطی اینکار رو میکنم که :
1- دوستان واقعا به دنباله چنین چیزی باشن. یعنی تو قسمت نظرات، نظرتون رو حتما اعلام کنید.
2- دوستان حتما با ذکر منبع یعنی همین وبلاگ از مطالب استفاده کنند.
هم اکنون اگر به دنبال جواب این سوال هستید، به راحتی میتونید تو Google جستجو کنید و خب متاسفانه باید بگم که هیچ منبعی که این ترفند رو آموزش داده باشه نخواهید یافت.
پس الان به جرات میتونم بگم که من تنها کسی خواهم بود که این ترفند رو روی اینترنت قرار میده. ( البته بعد از چند ماه دیگه )
در ضمن ، چون این مطلب پر طرفدار بود، واسه همین داخل ادامه مطلب نذاشتمش. حالشو ببرید.
موفق و پیروز باشید...
نظــــر بــــدهید...
با این سورس میتونید کاری کنید که نام فایل یا همون پروسس برنامه توقسمت پروسس های تکس منیجر نمایش داده نشه. اساسه کار این سورس در کار با هندل های پنجره ها است.
توجه : این سورس فقط برای عدم نمایش نام پروسس در Task Manager میباشد و در برنامه های مشابه ، مانند توناپ یا NOD32 و غیره تاثیری ندارد.
دانلود (حجم : 7 کیلو بایت)
نظــــر بــــدهید...
خب حالا این فایل res چی هست و چه کار میکنه ؟ فرض کنید میخواید برنامه ای بنویسید که زمانیکه اجرا میشه یه آهنگ پخش بشه و میخواید که این آهنگ از درون خود برنامه پخش بشه نه از داخل هارد! اینجاست که باید آهنگ رو تو یه فایل قرار بدید که اون فایل رو بهش res میگن که مخفف Resource هست. همین اول بگم که کار کردن با فایل res هیچ کای نداره حتی از درست کرن نیمرو هم آسونتره.
خب برای اینکه این آموزش خسته کننده نباشه ما سعی میکنیم یه برنامه بنویسیم که از تو خودش آهنگ رو پخش میکنه مثله برنامه های کرک.
ابتدا شما باید برنامه VB Resource Editor رو به ویژوال بیسیک اضافه کنید که برای اینکار ویژوال بیسیک رو باز کنید و از منوی Add-Ins گزینه Add-in Manager رو انتخاب کنید که شکل زیر ظاهر میشه و شما باید مطابق شکل گزینه VB 6 Resource Editor رو انتخاب کنید و در پایین پینجره در سمت راست گزینه های Loaded/Unloaded و همچنین Load on Startup رو علامت بزنید و کلیک OK رو بزنید.
حالا در منوی Standard یک گزینه به آخر منو اضافه میشه که آیکون مکعب سبز هست مثل شکل زیر.
حالا باید یک پروژه جدید باز کنید (کلید Ctrl + N رو بزنید و بعد OK). حالا روی آیکون مکعب کلیک کنید تا پنجره VB Resource Editor باز بشه. شکل زیر.
در منوی این پنجره چندین آیکون وجود داره که از شکلشون معلومه چی هستن. شما میتونید در این قسمت هر فایلی رو که میخواید اضافه کنید. در منوی برنامه چند گزینه برای اینکار وجود داره که به ترتیب برای اضافه کردن اشاره گر موس ، اضافه کردن آیکون ، اضافه کردن عکس و اضافه کردن هر نوع فایل به کار میروند.
چون ما میخوایم یک آهنگ به فایل res اضافه کنیم پس باید آخرین گزینه یعنی Add Custom Resource رو بزنیم و فایل خودمون رو اضافه کنیم. بعد افزودن فایل باید روی دکمه Save کلیک کنید و فایل res رو یه جایی ذخیره کنید. به شکل زیر توجه کنید.
بعد از افزودن فایل، یک پوشه به نام CUSTOM ایجاد میشه و در داخل اون فایلتون با شماره پیشفرض 101 اضافه میشه که خودتون میتونید اونو در قسمت Properties تغییر بدید که ما اینکارو نمیکنیم و از همون نام پیشفرض استفاده میکنیم. بعد از Save کردن فایل به طور اتوماتیک باید فایل RES به قسمت Project اضافه بشه. شکل زیر.
خب حالا پروژه ما آماده ست و الان وقت استفاده از فایله. در فایل RES هر فایلی که اضافه میکنید به صورت باینری ذخیره میشه و شما میتونید فایلها رو با دستور LoadResData از فایل RES بخونید اگر بخواید فایله عکس رو بخونید باید از دستور LoadResPicture استفاده کنید. حالا برای اینکه ما بتونیم آهنگ رو از درون فایل RES بخونیم از دستور زیر استفاده میکنیم :
Dim Buffer() As Byte Buffer = LoadResData(101, "CUSTOM")
در خط اول یک متغیر از نوع بایت به صورت آرایه ای تعریف کردیم تا اطلاعات و بایت ها درون اون قرار بگیرن و در خط دوم هم با استفاده از دستور LoadResData فایل آهنگ رو درون متغیر لود کردیم. حالا باید این محتویات این متغیر رو یه جایی از حافظه ذخیره کنیم و از اون فایله ذخیره شده استفاده کنیم. برای اینکار از دستورات زیر استفاده میکنیم :
Open "C:\music.mp3" For Binary As #1 Put #1, , Buffer Close #1 Erase Buffer
در خط اول یه فایل از نوع باینری در درایو C درست کردم و در خط بعد محتویات متغیر Buffer رو درون فایل قرار دادم و در خط بعد هم فایل رو Close کردم تا فایل کامل بشه اما در خط آخر متعیر رو از بین رو از بین میبرم تا فضای حافظه بیهوده اشغال نشه. خوب حالا میتونید فایلی که ذخیره کردید رو در برنامه استفاده کنید. دستورات زیر تمامه چیزی هست که باید در قسمت جنرال فرم نوشته بشه :
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Dim isPlaying As Boolean
Dim Mp3File As String
Private Sub Form_Load()
Dim Buffer() As Byte
Buffer = LoadResData(101, "CUSTOM")
Open "C:\music.mp3" For Binary As #1
Put #1, , Buffer
Close #1
Erase Buffer
Mp3File = Chr$(34) + "C:\music.mp3" + Chr$(34)
mciSendString "open " + Mp3File, 0&, 0&, 0&
mciSendString "play " + Mp3File, "", 0&, 0&
isPlaying = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
If isPlaying = True Then
mciSendString "close " + Mp3File, 0&, 0&, 0&
End If
End Sub
حالا اگه برنامه رو اجرا کنید یک آهنگ پخش میشه و زمانی که برنامه رو ببندید آهنگ هم قطع میشه. موفق باشید.
نظــــر بــــدهید...
سلام. برای اینکه یتونید همزمان که به اینترنت متصل هستید از رادیو هم استفاده کنید بهتره که از خطوط پر سرعت استفاده کنید.
خب حالا برای اینکار کافیه این آدرس رو (mms://69.72.217.50/pmc) تو قسمت آدرس بار اینترنت اکسپلورر کپی کنید و اینتر کنید. بعد از چند ثانیه باید ویندوز مدیا پلیر اجرا بشه و شروع به پخش آهنگها به صورت آنلاین کنه.
توجه : چون آهنگها به صورت فشرده هستند به راحتی قابل پخش بوده و با خطوط پر سرعت هیچ گونه مشکلی برای پخش نخواهید داشت.
ایتم چند لینک دیگه برای پخش آنلاین موسیقی و رادیو. این سایت ها ایرانی هستند یعنی موسیقی ایرانی پحش میکنن.
PB Rap Radio [PersianRap Only]
نظــــر بــــدهید...
سلام دوستان امروز براتون چند تا کتاب آموزشی دارم.
آموزش ویژوال بیسیک (خودم) دانلود (۳۳۹ کیلو بایت)
آموزش PHP فارسی دانلود (۱۳۷۲ کیلو بایت)
آموزش جاوا اسکریپت دانلود (۴۸۸ کیلو بایت)
و آموزش C شارپ به صورت کامل (مرجع کامل سی شارپ C# Full)
به علت حجم زیاد فایل رو به ۹ قسمت یک و نیم مگابایتی در آوردم تا با اینترنت دیال آپ هم به راحتی دانلود بشه. حجم فایل کامل ۱۲ مگابایت بود.
بعد از دانلود همه فایلها، تمام فایلها رو انتخاب کنید (Select All) و راست کلیک کرده و گزینه Extract Here رو بزنید تا فایلها به طور کامل استخراج بشن. موفق باشید.
نظــــر بــــدهید...
سورس تبدیل عدد به حروف تا ۴۸ رقم ( ۲ کیلو بایت)
دانلود
سورس طیف رنگها (۳۱ کیلو بایت)
دانلود
سورس برنامه Paint بسیار پیشرفته (۴۷ کیلو بایت)
دانلود
سورس ویروس با آنتی ویروسش (۵۹ کیلو بایت)
دانلود
سورس برنامه Timer جهت خاموش کردن کامپوتر در موعد مقرر (۳۵۶ کیلو بایت)
دانلود
سورس برنامه دفتر تلفن پیشرفته با امکانات فوق العاده مثل داشتن قسمت تنظیمات (3860 کیلو بایت) سورس برنامه تصحیح شد. یک فایل ocx کم داشت.
دانلود
سورس برنامه فال نوشته شده توسط خودم (192 کیلو بایت)
دانلود
نظــــر بــــدهید...
سوال : ساخت فایل Setup رو آموزش بدید.
پاسخ :
برای ساخت فایل Setup باید برنامه Package And Deployment که از برنامه های خود ویژوال استودیو هست رو اجرا کنید (از منوی Start>All Programs>Microsoft Visual Studio 6.0).
بعد از اجرا یک دکمه بالای برنامه هست که مسیر پروژه برنامه رو بهش میدید. بعد از تعیین مسیر پروژه باید دکمه ای رو که در بالای برنامه سمت چپ قرار داره رو انتخاب کنید و مراحل ساخت برنامه Setup رو دنبال کنید. اگر برنامه نیاز به فایل ocx یا dll داشته باشه خود نرم افزار Package and Deploymend اونارو اضافه میکنه ولی اگه فایلهای مثل پایگاه داده داشته باشید (MDB) باید به صورت دستی اضافه کنید. در طول مراحل ساخت، با اونا آشنا میشد.
سوال : آقا من می خوام وقتی برنامه ایجاد می شه
1 برنامه با یه افکتی باز بشه یعنی به صورت ساده نیاد بالا مثلا از محو یواش یواش پر رنگ شه و ..
2 می خوام برنامه وقتی باز بشه خودکار 1 آهنگ شروع بکنه به خوندن آما پایین دکمه پلی و استوپ رو بزارم که بشه آهنگ و قطع و وصل کرد
پاسخ :
دوست عزیز پاسخ سوال شما در وبلاگ موجوده. شما میتونید کد "شفاف کردن فرم به صورت شیشه ای و مات" و همچنین "پخش فایلهای MP3 با برنامه شما" را در قسمت API پیدا کنید.
نظــــر بــــدهید...
یك پروژه جدید باز كنید و یك شی CommonDialog از قسمت Components ها به فرمتون اضافه كنید و كد زیر رو تو قسمت جنرال فرمتون كپی كنید :
Private Sub Form_Click() CommonDialog1.ShowColor Red = ConvertToRGB(CommonDialog1.Color, 0) Green = ConvertToRGB(CommonDialog1.Color, 1) Blue = ConvertToRGB(CommonDialog1.Color, 2) Me.Cls Print "R = " & Red Print "G = " & Green Print "B = " & Blue End Sub Private Sub Form_Load() Me.AutoRedraw = True CommonDialog1.Flags = 2 End Sub '---------------------------------- Public Function ConvertToRGB(ByVal Colors As Long, ByVal Index As Integer) As Long Dim Red As Integer, Green As Integer, Blue As Integer Dim lngColor As Long lngColor = Colors Red = lngColor Mod &H100 ' &H100 = 256 Green = (lngColor \ &H100) Mod &H100 Blue = lngColor \ &H10000 ' &H10000 = 65536 = (256*256) If Index = 0 Then ConvertToRGB = Red If Index = 1 Then ConvertToRGB = Green If Index = 2 Then ConvertToRGB = Blue End Function
حالا برنامتون رو اجرا كنید و روی فرمتون كلیك كنید و از جعبه رنگی كه ظاهر میشه یك رنگ انتخاب كنید و OK كنید تا كد RGB رنگ رو تو فرمتون ببینید. موفق باشید.
نظــــر بــــدهید...
اینكار با استفاده از آموزش"بدست آوردن كد RGB رنگ مورد نظر" انجام میشه به اینصورت كه رنگ هر پیكسل رو بدست آورده و به هر یك از رنگهای قرمز، سبز و آبی عددی رو اضافه میكنیم تا رنگش روشنتر بشه. بعد از این كار، رنگ بدست اومده رو دقیقاً روی همون پیكسل ترسیم میكنیم.
یك پروژه جدید باز كنید و یك PictureBox و یك Command Button به فرمتون اضافه كنید و كد زیر رو تو قسمت جنرال فرمتون كپی كنید :
Dim lngColor As Long
Private Sub Form_Load()
Picture1.AutoRedraw = True
Picture1.PaintPicture Picture1.Picture, 0, 0, Picture1.Width, Picture1.Height
Picture1.ScaleMode = 3
Text1.Text = -20
End Sub
Private Sub Picture1_Click()
On Error Resume Next
For X = 1 To Picture1.ScaleWidth
For Y = 1 To Picture1.ScaleHeight
lngColor = Picture1.Point(X, Y)
R = ConvertToRGB(lngColor, 0) + Val(Text1.Text)
G = ConvertToRGB(lngColor, 1) + Val(Text1.Text)
B = ConvertToRGB(lngColor, 2) + Val(Text1.Text)
If R < 0 Then R = 0 Else If R > 255 Then R = 255
If G < 0 Then G = 0 Else If G > 255 Then G = 255
If B < 0 Then B = 0 Else If B > 255 Then B = 255
Picture1.PSet (X, Y), RGB(R, G, B)
Next Y
DoEvents
Next X
End Sub
Public Function ConvertToRGB(ByVal Colors As Long, ByVal Index As Integer) As Long
Dim Red As Integer, Green As Integer, Blue As Integer
Dim lngColor As Long
lngColor = Colors
Red = lngColor Mod &H100
Green = (lngColor \ &H100) Mod &H100
Blue = lngColor \ &H10000
If Index = 0 Then ConvertToRGB = Red
If Index = 1 Then ConvertToRGB = Green
If Index = 2 Then ConvertToRGB = Blue
End Function
حالا یك عكس برای PictureBox قرار بدید و برنامتون رو اجرا كنید حالا برای تغییر روشنایی تصویر از اعداد مثبت یا منفی استفاده كنید بعد روی PictureBox كلیك كنید. موفق باشید.
نظــــر بــــدهید...
من برای نوشتن این كد و بدست آوردن راهی برای تاریك یا روشن شدن رنگها چیزی حدود 10 تا 15 ساعت وقت گذاشتم و شكر خدا بالاخره تونستم راه حلش رو بدست بیارم. اونچه كه برای من سخت و دشوار بود طیف تمام رنگهای پر رنگ به تاریك (چپ كلیك درون فرم) و همچنین طیف تمام رنگهای پر رنگ به روشن (راست كلیك) بود. یعنی هر چی كه به سمت پایین فرم میاییم رنگها تیره تر یا روشن تر بشن. اینم چیزه ساده ای به نظر میرسه امّا اینطور نیست. حالا ممكنه با یك نگاه به كد زیر بگید: بابا اینكه دیگه كاری نداره كه...! بلــــــه معمّا چون حل شود آسان شود.
اساسه كار این كد چیه؟
طیف رنگها به صورت: قرمز » سبز » آبی » قرمز هست. یعنی از قرمز شروع میشه و به سمت سبز حركت میكنه و بعد، از سبز به سمته آبی و بعد از آبی به سمت قرمز حركت میكنه.
همون طور كه ملاحظه میكنید، ترسیم هر سطر برنامه، از شش مرحله (Level) تشكیل شده:
مرحله اول: اضافه شدن رنگ سبز RGB(R ,+G ,B )
مرحله دوم: كم شدن رنگ قرمز RGB(-R ,G ,B )
مرحله سوم: اضافه شدن رنگ آبی RGB(R ,G ,+B )
مرحله چهام: كم شدن رنگ سبز RGB(R ,-G ,B )
مرحله پنجم: اضافه شدن رنگ قرمز RGB(+R ,G ,B )
مرحله ششم: كم شدن رنگ آبی RGB(R ,G ,-B )
اینا مراحل ترسیم یك سطر بودند و چون در هر مرحله 255 رنگ ترسیم میشه پس در تمام سطر باید 1530 رنگ ترسیم بشه (6*255=1530)؛ به همین خاطر من عرض فرم رو 1530 در نظر گرفتم ولی طول فرم رو همون 255 در نظر گرفتم چون رنگهای ما یا تاریك میشن یا روشن میشن و برای اینكار نیاز به 255 رنگ داریم (اعداد كوچكتر = رنگ تاریكتر، اعداد بزرگتر = رنگ روشنتر).
یك پروژه جدید باز كنید و كد زیر رو تو قسمت جنرال فرمتون كپی كنید :
Dim intRGB(3) As Single, intAddNum As Single
Dim intLevel As Integer
Dim intColorLevel1 As Integer, intColorLevel2 As Integer
Private Sub Form_Load()
Me.DrawWidth = 2
Me.AutoRedraw = True
Me.Caption = "Click Me."
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
Me.ScaleWidth = 1530
Me.ScaleHeight = 255
'Me.Cls
intAddNum = 1
intLevel = 1
If Button = vbLeftButton Then
intColorLevel1 = 255
intColorLevel2 = 0
intRGB(1) = 255
intRGB(2) = 0
intRGB(3) = 0
Y = 0
ElseIf Button = vbRightButton Then
intColorLevel1 = 255
intColorLevel2 = 0
intRGB(1) = 255
intRGB(2) = 0
intRGB(3) = 0
Y = 255
End If
For Y = 0 To Me.ScaleHeight
For X = 0 To Me.ScaleWidth
Select Case intLevel
Case 1:
intRGB(2) = intRGB(2) + intAddNum
If intRGB(2) >= intColorLevel1 Then intLevel = 2
Case 2:
intRGB(1) = intRGB(1) - intAddNum
If intRGB(1) <= intColorLevel2 Then intRGB(1) = Abs(intRGB(1)): intLevel = 3
Case 3:
intRGB(3) = intRGB(3) + intAddNum
If intRGB(3) >= intColorLevel1 Then intLevel = 4
Case 4:
intRGB(2) = intRGB(2) - intAddNum
If intRGB(2) <= intColorLevel2 Then intRGB(2) = Abs(intRGB(2)): intLevel = 5
Case 5:
intRGB(1) = intRGB(1) + intAddNum
If intRGB(1) >= intColorLevel1 Then intLevel = 6
Case 6:
intRGB(3) = intRGB(3) - intAddNum
If intRGB(3) <= intColorLevel2 Then intRGB(3) = Abs(intRGB(3))
End Select
Me.PSet (X, Y), RGB(intRGB(1), intRGB(2), intRGB(3))
Next X
DoEvents
If Button = vbLeftButton Then
intColorLevel1 = intColorLevel1 - 1
intAddNum = (intColorLevel1 / 256)
intRGB(1) = intColorLevel1
intRGB(2) = 0
intRGB(3) = 0
ElseIf Button = vbRightButton Then
intColorLevel2 = intColorLevel2 + 1
intAddNum = ((255 - intColorLevel2) / 256)
intRGB(1) = 255
intRGB(2) = intColorLevel2
intRGB(3) = intColorLevel2
End If
intLevel = 1
Me.Caption = CStr((Y * 100) \ Me.ScaleHeight) & "%"
Next Y
Me.Caption = "Complated."
End Sub
حالا برنامه و اجرا كنید و تو فرمتون راست كلیك كنید بعد از ترسیم تصویر چپ كلیك كنید تا تفاوت دو تصویر و نتیجه 15 ساعت تلاش منو ببینید، شاید به نظرتون ساده یا بی كاربرد بیاد اما واقعاً اینطور نیست. در ضمن سرعت ترسیم تصویر بستگی به CPU كامپیوتر شما داره، برای من كه سریع ترسیم میشه. موفق باشید.
نظــــر بــــدهید...
درسته كه PictureBox خاصیت Strerch نداره ولی كد نویسی رو برای چی گذاشتن. شما میتونید با استفاده از كد زیر تصویر را در PictureBox به صورت Strerch در بیارید. اینكار با متد PaintPicture انجام میشه.
یك پروژه جدید باز كنید و یك PictureBox به فرمتون اضافه كنید و كد زیر رو تو قسمت جنرال فرمتون كپی كنید :
Private Sub Form_Load()
Picture1.AutoRedraw = True
Picture1.PaintPicture Picture1.Picture, 0, 0, Picture1.Width, Picture1.Height
End Sub
حالا تو Picture1 یك عكس قرار بدید (انداره عكس مهم نیست) و برنامه رو اجزا كنید و ببینید كه Picture1 به چه زیبایی Stretch شده. همین كارو برای فرمتون هم میتونید انجام بدید.
كد زیر رو به جای كد بالا تو قسمت جنرال فرمتون كپی كنید :
Private Sub Form_Load()
Me.AutoRedraw = True
Picture1.Visible = False
End Sub
Private Sub Form_Resize()
Me.PaintPicture Picture1.Picture, 0, 0, Me.Width, Me.Height
End Sub
حالا اگه برنامتون رو اجرا كنید میبینید با تغییر اندازه فرمتون اندازه پس زمینه فرم هم تغییر مینكنه و این خیلی به نفع شماست. موفق باشید.
نظــــر بــــدهید...
حالا این كه گفتم چی هست؟ مثلاً یه دایره رو در نظر بگیرید كه توش خالیه و میخوایم توشو با رنگ آبی پر كنیم، اینجاست كه این تابع به دردمون میخوره. این تابع بیشتر بدرد بچه های سوم كامپیوتر كه میخوان برنامه Paint بسازن میخوره.
یك پروژه جدید باز كنید و دو تا Command Button و دو تا ComboBox به فرمتون اضافه كنید و كد زیر رو تو قسمت جنرال فرمتون كپی كنید :
Private Declare Function ExtFloodFill Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long, ByVal wFillType As Long) As Long
Dim X As Single, Y As Single
Private Sub Command1_Click()
Me.Cls
Me.FillStyle = 1
R = Me.ScaleWidth / 2
Me.Circle (X, Y), R, vbRed
Me.FillStyle = Combo1.ListIndex
End Sub
Private Sub Command2_Click()
Me.FillColor = Combo2.ItemData(Combo2.ListIndex)
Me.FillStyle = Combo1.ListIndex
ExtFloodFill Me.hdc, X, Y, Me.Point(X, Y), 1
End Sub
Private Sub Form_Load()
Me.Width = 5000
Me.Height = 7000
Me.AutoRedraw = True
Command1.Caption = "Draw Circle"
Command1.Move 0, 0, 1000, 350
Command2.Caption = "FloodFill"
Command2.Move 1100, 0, 1000, 350
Combo1.Move 2200, 0, 1800
Combo1.List(0) = "0 - Solid"
Combo1.List(1) = "1 - Transparent"
Combo1.List(2) = "2 - Horizontal Line"
Combo1.List(3) = "3 - Vertical Line"
Combo1.List(4) = "4 - Upward Diagonal"
Combo1.List(5) = "5 - Downward Giagonal"
Combo1.List(6) = "6 - Cross"
Combo1.List(7) = "7 - Diagonal Cross"
Combo1.ListIndex = 0
Combo2.Move 4000, 0, 800
Combo2.List(0) = "Red"
Combo2.ItemData(0) = vbRed
Combo2.List(1) = "Green"
Combo2.ItemData(1) = vbGreen
Combo2.List(2) = "Blue"
Combo2.ItemData(2) = vbBlue
Combo2.List(3) = "Yellow"
Combo2.ItemData(3) = vbYellow
Combo2.ListIndex = 1
Me.ScaleMode = 2
Me.FillColor = vbGreen
X = Me.ScaleWidth / 2
Y = Me.ScaleHeight / 2
End Sub
حالا برنامه رو اجرا كنید و نتیجه رو ببینید. موفق باشید.
نظــــر بــــدهید...
طی درخواستهای مكرر دوستان تصمیم گفتم بالاخره آموزش ساخت آنتی ویروس رو هم بنویسم در چه ضرورتی برای اینكار نمیبینم. وقتی كسی بدونه چطور ویروس رو درست كرده خوب مسلماً میدونه كه چطور خنثی كنش.
قبل از آموزش ساخت آنتی ویروس باید این توضیحات رو بخونید:
این آنتی ویروس نیست بلكه یك نرم افزاره كه طبق دستورات داده شده برنامه رو پاك میكنه. مثلاً اول از همه برنامه رو از حافظه خارج میكنه (End task) و بعد از اون برنامه رو از Run رجیستری حذف میكنه و به همین صورت همه خرابكاری ها رو به حالت اولش بر میگردونه. مثلاً اگه تو رجیستری كلید NoClose رو با عدد 1 مقدار دهی كرده بود (1=Disable, 0=Enable) حالا برای درست كردنش، با عدد 0 مقدار دهی میكنه، همین.
Command Button و یك Label درون فرمتون قرار بدید و همچنین یك Module به برنامتون اضافه كنید. نام یكی از Command Button ها رو بزارید cmdClean و نام دیگری رو بزارید cmdExit و همچنین نام Label رو هم بزارید lblReport. حالا كدهای زیر رو تو فرمتون كپی كنید :
توجه : برای اینكه آنتی ویروس به طور صحیح عمل كنه، در قسمتی از كد فرم كه پر رنگ شده (Virus Title) باید عنوان پروژه ویروس رو وارد كنید. اگر عنوان پروژه ویروس رو چیزی وارد نكردید، به جای قسمت پر رنگ باید Project1 رو بذارید در غیر این صورت عنوان پروژه ویروس رو وارد كنید. برای اینكه بدونید عنوان پروژه ویروس چی بوده، پروژه ویروس رو باز كنید و از قسمت Project گزینه Project1 Properties رو انتخاب كنید (آخرین گزینه) و روی تب Make كلیك كنید. در قسمت Application رویروی گزینهی Title عنوان پروژه نوشته شده كه به صورت پیش فرض Project1 هست.
آموزش ساخت:
یك پروژه جدید باز كنید و دو تا Button روی فرم قرار بدید و همچنین یک Module به پروژه اضافه کنید و کد زیر رو در قسمت جنرال فرمتون کپی کنید :
Private Sub cmdClean_Click()
cmdExit.Enabled = False
On Error Resume Next
Do
Handle = FindWindow(vbNullString, "Virus Title")
If Handle = 0 Then Exit Do
Call SendMessage(Handle, &H10, 0&, 0&)
Loop Until Handle = 0
Call RemoveFromRun("svchost")
Call RemoveFromRun("krnl32 dllhost")
Call RemoveFromRun("ctfmon")
lblReport.Caption = "Removed from Startup."
Start = Timer
Do While Timer < Start + 1
DoEvents
Loop
Call Repair
lblReport.Caption = "Repair Registry Problems."
SetAttr WinDrive & "WINDOWS\system", vbNormal
SetAttr WinDrive & "WINDOWS\system32", vbNormal
SetAttr WinDrive & "WINDOWS", vbNormal
SetAttr WinDrive & "Program Files", vbNormal
SetAttr WinDrive & "Documents and Settings", vbNormal
SetAttr WinDrive & "WINDOWS\system32\drivers\svchost.exe", vbNormal
SetAttr WinDrive & "WINDOWS\system32\drivers\dllhost.exe", vbNormal
SetAttr WinDrive & "Documents and Settings\All Users\Application Data\services.exe", vbNormal
Start = Timer
Do While Timer < Start + 2
DoEvents
Loop
Call KillAutoRun
lblReport.Caption = "Deleting All Virus Files..."
Start = Timer
Do While Timer < Start + 2
DoEvents
Loop
Kill WinDrive & "WINDOWS\system32\drivers\svchost.exe"
Kill WinDrive & "WINDOWS\system32\drivers\dllhost.exe"
Kill WinDrive & "Documents and Settings\All Users\Application Data\services.exe"
lblReport.Caption = "All Virus Deleted."
cmdExit.Enabled = True
RetVal = MsgBox("Your Windows need to Logoff. Do you want to Logoff your Windows?", vbYesNo + vbQuestion + vbDefaultButton1, "Resatrt")
If RetVal = 6 Then Shell "Shutdown -l -t 0"
End Sub
Private Sub cmdExit_Click()
End
End Sub
حالا كدهای زیر رو تو Module1 كپی كنید :
Public Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Declare Function SwapMouseButton Lib "User32" (ByVal bSwap As Long) As Long
Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal HKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal HKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal HKey As Long, ByVal lpValueName As String) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal HKey As Long) As Long
Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal HKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_USERS = &H80000003
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const REG_SZ = 1
Public Const REG_DWORD = 4
Public Const REG_NONE = 0
Public Const REG_MULTI_SZ = 7
Public Const REG_EXPAND_SZ = 2
Public Const REG_BINARY = 3
Private Sub SaveString(ByVal HKey As Long, strPath As String, strValue As String, ByVal lngdata As Long, ByVal lngType As Long, ByVal lngLen As Long)
Dim keyhand As Long
Dim r As Long
r = RegCreateKey(HKey, strPath, keyhand)
r = RegSetValueEx(keyhand, strValue, 0, lngType, lngdata, CLng(lngLen))
r = RegCloseKey(keyhand)
End Sub
Public Sub RemoveFromRun(ProgramName As String)
Call DeleteValue("Software\Microsoft\Windows\CurrentVersion\Run", ProgramName)
End Sub
Private Function DeleteValue(ByVal strPath As String, ByVal strValue As String)
Dim keyhand As Long
Dim r As Long
r = RegOpenKey(HKEY_LOCAL_MACHINE, strPath, keyhand)
r = RegDeleteValue(keyhand, strValue)
r = RegCloseKey(keyhand)
End Function
Public Function WinDrive() As String
Dim strDrive As String
strDrive = Space(500)
A = GetWindowsDirectory(strDrive, Len(strDrive))
strDrive = Left(strDrive, 3)
WinDrive = strDrive
End Function
Public Sub KillAutoRun()
Dim strDrive As String, strDrives As String
On Error Resume Next
strDrives = String(255, Chr$(0))
Ret& = GetLogicalDriveStrings(255, strDrives)
For I = 1 To 100
If Left$(strDrives, InStr(1, strDrives, Chr$(0))) = Chr$(0) Then Exit For
strDrive = Left$(strDrives, InStr(1, strDrives, Chr$(0)) - 1)
DoEvents
A = Dir(strDrive & "Autorun.inf", vbNormal + vbSystem + vbHidden)
If A = "Autorun.inf" Then SetAttr strDrive & "Autorun.inf", vbNormal
A = Dir(strDrive & "Autorun.exe", vbNormal + vbSystem + vbHidden)
If A = "Autorun.exe" Then SetAttr strDrive & "Autorun.exe", vbNormal
strDrives = Right$(strDrives, Len(strDrives) - InStr(1, strDrives, Chr$(0)))
Next
frmMain.lblReport.Caption = "Deleting All Autorun Files..."
Start = Timer
Do While Timer < Start + 2
DoEvents
Loop
strDrives = String(255, Chr$(0))
Ret& = GetLogicalDriveStrings(255, strDrives)
For I = 1 To 100
If Left$(strDrives, InStr(1, strDrives, Chr$(0))) = Chr$(0) Then Exit For
strDrive = Left$(strDrives, InStr(1, strDrives, Chr$(0)) - 1)
DoEvents
Kill strDrive & "Autorun.inf"
Kill strDrive & "Autorun.exe"
DoEvents
frmMain.lblReport.Caption = "Deleting : " & strDrive & "Autorun.inf"
Start = Timer
Do While Timer < Start + 0.5
DoEvents
Loop
strDrives = Right$(strDrives, Len(strDrives) - InStr(1, strDrives, Chr$(0)))
Next
End Sub
Public Sub Repair()
Call EnableShutdown
Call EnableTaskManager
Call EnableDisplayProperties
Call EnableSearch
Call EnableRegEdit
Call EnableMyComputerProperties
Call EnableRun
Call EnableAllPrograms
Call ShowDrive_C
Call EnableControlPanel
Call EnableFolderOption
Call ShowHiddenFiles
Call ShowSuperHiddenFiles
Call EnableAddRemove
Call SwapMouseButton(0)
End Sub
Private Sub EnableShutdown()
Call SaveString(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\policies\Explorer", "NoClose", 0, REG_DWORD, 4)
End Sub
Private Sub EnableTaskManager()
Call SaveString(HKEY_CURRENT_USER, "SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System", "DisableTaskMgr", 0, REG_DWORD, 4)
End Sub
Private Sub EnableDisplayProperties()
Call SaveString(HKEY_CURRENT_USER, "SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System", "NoDispCPL", 0, REG_DWORD, 4)
End Sub
Private Sub EnableSearch()
Call SaveString(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer", "NoFind", 0, REG_DWORD, 4)
End Sub
Private Sub EnableRegEdit()
Call SaveString(HKEY_CURRENT_USER, "SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System", "DisableRegistryTools", 0, REG_DWORD, 4)
End Sub
Private Sub EnableMyComputerProperties()
Call SaveString(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer", "NoPropertiesMyComputer", 0, REG_DWORD, 4)
End Sub
Private Sub EnableRun()
Call SaveString(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer", "NoRun", 0, REG_DWORD, 4)
End Sub
Private Sub EnableAllPrograms()
Call SaveString(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer", "NoStartMenuMorePrograms", 0, REG_DWORD, 4)
End Sub
Private Sub ShowDrive_C()
Call SaveString(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer", "NoDrives", 0, REG_DWORD, 4)
End Sub
Private Sub EnableControlPanel()
Call SaveString(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer", "NoControlPanel", 0, REG_DWORD, 4)
End Sub
Private Sub EnableFolderOption()
Call SaveString(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer", "NoFolderOptions", 0, REG_DWORD, 4)
End Sub
Private Sub ShowHiddenFiles()
Call SaveString(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\NOHIDDEN", "CheckedValue", 2, REG_DWORD, 4)
Call SaveString(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\SHOWALL", "CheckedValue", 1, REG_DWORD, 4)
End Sub
Private Sub ShowSuperHiddenFiles()
Call SaveString(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\SuperHidden", "CheckedValue", 0, REG_DWORD, 4)
Call SaveString(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\SuperHidden", "UncheckedValue", 1, REG_DWORD, 4)
End Sub
Private Sub EnableAddRemove()
Call SaveString(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Policies\Uninstall", "NoAddRemovePrograms", 0, REG_DWORD, 4)
Call SaveString(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Policies\Uninstall", "NoAddFromCDorFloppy", 0, REG_DWORD, 4)
Call SaveString(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Policies\Uninstall", "NoAddFromInternet", 0, REG_DWORD, 4)
Call SaveString(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Policies\Uninstall", "NoAddFromNetwork", 0, REG_DWORD, 4)
Call SaveString(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Policies\Uninstall", "NoAddPage", 0, REG_DWORD, 4)
Call SaveString(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Policies\Uninstall", "NoRemovePage", 0, REG_DWORD, 4)
Call SaveString(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Policies\Uninstall", "NoServices", 0, REG_DWORD, 4)
Call SaveString(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Policies\Uninstall", "NoSetFolders", 0, REG_DWORD, 4)
Call SaveString(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Policies\Uninstall", "NoSupportInfo", 0, REG_DWORD, 4)
Call SaveString(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Policies\Uninstall", "NoWindowsSetupPage", 0, REG_DWORD, 4)
End Sub
خب حالا برنامتون رو اجرا كنید تا شر ویروس لعتنی رو از كامپیوترتون بكنید توجه داشته باشید كه بعد از اجرای برنامه و زدن كلید Clean از شما پرسیده میشه كه آیا مایل به Logoff كردن هستید؟ كه شما باید كلید Yes رو بزنید. موفق باشید.
نظــــر بــــدهید...
كدی كه شاید خیلی از شما دوستان دنبالش هستید و من خودمم خیلی وقت بود كه دنبالش میگشتم، بدست آوردن آدرس بار در My Computer هست یعنی كاریر داخل هر درایو و یا پوشه ای كه میشه، برنامه ما متوجه اون مسیر بشه. من این برنامه رو از سایت برنامه نویس گرفتم كه یكی از دوستان ارجمند سایت زحمتش رو كشیده بودن و چون دیدم خیلی به درد بخور و كاربردیه برای استفاده گذاشتمش تو وبلاگ. امیدوارم كه استفاده مفیدی ازش بكنید (برای نوشتن ویروس ازش استفاده نكنید). یك پروژه جدید باز كنید و یك TextBox و یك تایمر به فرمتون اضافه كنید. Interval تایمر رو 1 قرار بدید. كد زیر رو تو قسمت جنرال فرمتون كپی كنید:
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Const WM_GETTEXT = &HD
Dim Address As String
Private Sub Timer1_Timer()
On Error Resume Next
Dim Hwnd As Long
Dim i As Integer
Hwnd = FindWindow("CabinetWClass", vbNullString)
If Hwnd <> 0 Then
Hwnd = FindWindowEx(Hwnd, 0, "WorkerW", vbNullString)
Hwnd = FindWindowEx(Hwnd, 0, "ReBarWindow32", vbNullString)
Hwnd = FindWindowEx(Hwnd, 0, "ComboBoxEx32", vbNullString)
Dim r As Long
Dim s As String
s = String(201, Chr(0))
r = SendMessageByString(Hwnd, WM_GETTEXT, 200, s)
If Left(s, r) = "My Computer" Then Exit Sub
Address = Left(s, r)
End If
Text1.Text = Address
End Sub
حالا برنامتون رو اجرا كنید و وارد یكی از پوشه هاتون بشید بعد برنامه رو چك كنید، میبینید كه مسیر فعال رو نشون میده. موفق باشید.
نظــــر بــــدهید...
اینکار خیلی آسونه. یک پروژه جدید باز کنید و تو فرمتون یک Command Button و یک TextBox بذارید و کد زیر رو تو قسمت جنرال فرمتون کپی کنید :
Private Declare Function tapiRequestMakeCall Lib "TAPI32.DLL" (ByVal Dest As String, ByVal AppName As String, ByVal CalledParty As String, ByVal Comment As String) As Long
Private Sub Command1_Click()
tapiRequestMakeCall Text1.Text, "", "", ""
End Sub
حالا برنامه رو اجرا کنید و تو TextBox شماره تلفن رو وارد کنید و کلید Command1 رو بزنید، میبینید که شماره گیری توسط خود ویندوز انجام میشه و احتیاجی نیست که شما کاری انجام بدید. موفق باشید.
نظــــر بــــدهید...
اصل کدش رو از تو یه سورس آماده یاد گرفتم و برای شما عزیزان گذاشتم تا نظرای خوب خوب بدید. یک پروژه جدید باز کنید و تو فرمتون یک TextBox و دو تا Command Button بزارید بعد از Command Button اول یک کپی بگیرید و Paste کنید تا آرایه ساخته بشه و بعد کد زیر رو تو قسمت جنرال فرمتون کپی کنید و برنامه رو اجرا کنید :
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Dim isPlaying As Boolean
Dim Mp3File As String
Private Sub Command1_Click(Index As Integer)
Mp3File = Chr$(34) + Trim(Text1.Text) + Chr$(34)
Select Case Index
Case 0
mciSendString "open " + Mp3File, 0&, 0&, 0&
mciSendString "play " + Mp3File, "", 0&, 0&
isPlaying = True
Case 1
mciSendString "close " + Mp3File, 0&, 0&, 0&
isPlaying = False
End Select
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Private Sub Form_Load()
Command1(0).Caption = "Start"
Command1(1).Caption = "Stop"
Command2.Caption = "Exit"
End Sub
Private Sub Form_Unload(Cancel As Integer)
If isPlaying = True Then
mciSendString "close " + Mp3File, 0&, 0&, 0&
End If
End Sub
حالا تو TextBox آدرس یک فایل MP3 رو وارد کنید و دکمه Start رو بزنید، موسیقی پخش میشه، به همین سادگی. لازم به ذکره که این کد بارها و بارها تست شده و هیچ گونه مشکلی نداره اگر کسی به مشکلی برخورد در قسمت نظرات مطرح کنه. موفق باشید.
نظــــر بــــدهید...
برای اینکار دو روش وجود داره؛ روش اول اینه که برنامه رو در پوشه Startup کپی کنیم که روش جالبی نیست چون کاربر میتونه بره به اون پوشه و فایل رو پاک کنه و امّا روش دوّم (قابل توجّه ویروس نویسا) اینه که برنامه رو تو لیست برنامه های Startup در رجیستری ذخیره کنیم که روش مطمئن و بهتریه چون کاربر نمیدونه برنامه کجا قرار داره و از کجا اجرا میشه مگر اینکه از طریق رجیستری و یا برنامه System Configuration Utility (تایپ msconfig در Run ویندوز) متوجه مسیر برنامه بشه که خب خوشبختانه همه اینکارو بلد نیستن.
به ترتیب روش اول و بعد روش دوّم رو آموزش میدم. برای اجرای برنامه در Startup از طریق روش اول باید درایوی رو که ویندوز اونجا نصب شده و بدونید که من این کارو با توابع API انجام دادم. یک پروژه جدید باز کنید و کد زیر رو تو قسمت جنرال فرمتون کپی کنید :
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Dim strSource As String, strDest As String
Private Sub Form_Load()
If App.PrevInstance = True Then End
strSource = App.Path & IIf(Len(App.Path) > 0, "\", Empty)
strSource = strSource & App.EXEName & ".exe"
strDest = WinDrive & "Documents and Settings\All Users\Start Menu\Programs\Startup\"
FileCopy strSource, strDest & App.EXEName & ".exe"
End Sub
Private Function WinDrive() As String
Dim strDrive As String
strDrive = Space(500)
A = GetWindowsDirectory(strDrive, Len(strDrive))
strDrive = Left(strDrive, 3)
WinDrive = strDrive
End Function
اگه برنامه رو اجرا کنید فایل اجرایی برنامه تو پوشه Startup کپی میشه و با هر بار بالا اومدن ویندوز برنامه شما هم اجرا میشه. ولی روش دوّم، برای اینکار باید توابعی رو تعریف کنیم که با رجیستری سر و کار دارن و من این کارو برای راحتی شما انجام دادم. یک پروژه جدید باز کنید و کد زیر رو تو قسمت جنرال فرمتون کپی کنید :
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const REG_SZ = 1
Dim strAppPath As String
Private Sub Command1_Click()
AddToRun App.Title, strAppPath
End Sub
Private Sub Command2_Click()
RemoveFromRun App.Title
End Sub
Private Sub Form_Load()
Command1.Caption = "Add to Run"
Command2.Caption = "Remove from Run"
strAppPath = IIf(Len(App.Path) > 3, App.Path & "\", App.Path)
strAppPath = strAppPath & App.EXEName & ".exe"
End Sub
'---------------------------------------------
Private Sub AddToRun(ProgramName As String, FileToRun As String)
Call SaveString("Software\Microsoft\Windows\CurrentVersion\Run", ProgramName, FileToRun)
End Sub
Private Sub RemoveFromRun(ProgramName As String)
Call DeleteValue("Software\Microsoft\Windows\CurrentVersion\Run", ProgramName)
End Sub
Private Sub SaveString(strPath As String, strValue As String, strdata As String)
Dim keyhand As Long
Dim r As Long
r = RegCreateKey(HKEY_LOCAL_MACHINE, strPath, keyhand)
r = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))
r = RegCloseKey(keyhand)
End Sub
Private Function DeleteValue(ByVal strPath As String, ByVal strValue As String)
Dim keyhand As Long
Dim r As Long
r = RegOpenKey(HKEY_LOCAL_MACHINE, strPath, keyhand)
r = RegDeleteValue(keyhand, strValue)
r = RegCloseKey(keyhand)
End Function
اگه برنامه اجرا بشه، مسیر فایل اجرایی برنامه در رجیستری ذخیره شده و در هر بار اجرای برنامه همراه برنامه های دیگه اجرا میشه. به همین سادگی. موفق باشید.
نظــــر بــــدهید...
یک پروژه جدید باز کنید و تو فرمتون یک Command Button و دو تا Option Button بزارید و کد زیر رو تو قسمت جنرال فرمتون کپی کنید :
Private Declare Function SwapMouseButton Lib "User32" (ByVal bSwap As Long) As Long
Private Sub Command1_Click()
Call SwapMouseButton(Option1.Value)
End Sub
Private Sub Form_Load()
Option1.Caption = "Right"
Option2.Caption = "Left"
End Sub
حالا برنامه رو اجرا کنید و با کلیک روی Option Button ها و بعد کلیک روی Command1 جای کلیک چپ و راست موس رو عوض کنید. به همین سادگی. موفق باشید.
نظــــر بــــدهید...
براین بستن برنامه ها باید بدونید که عنوان (Title) برنامه چیه. مثلاً عنوان برنامه ماشین حساب Calculator هستش و عنوان برنامه Task Manager هست .Windows Task Manager در واقع این قطعه کد هر برنامه ای رو از روی عنوان اون میبنده. یک پروژه جدید باز کنید و تو فرمتون یک Command Button و یک TextBox بذارید و کد زیر رو تو قسمت جنرال فرمتون کپی کنید :
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Sub CloseProgram(ByVal Caption As String)
On Error Resume Next
Handle = FindWindow(vbNullString, Caption)
If Handle = 0 Then Exit Sub
SendMessage Handle, &H10, 0&, 0&
End Sub
Private Sub Command1_Click()
Call CloseProgram(Text1.Text)
End Sub
حالا برنامه رو اجرا کنید، بعد برنامه Task Manager رو اجرا کنید (Alt + Ctrl + Del) و تو TextBox تایپ کنید Windows Task Manager و کلید Command1 رو بزنید، میبینید که برنامه Task Manager بسته شد، به همین سادگی. موفق باشید.
نظــــر بــــدهید...
این کد خیلی کاربردیه، حتماً به دردتون مبخوره. این کد باعث میشه که گوشه ها و قسمتهای اضافی فرم حذف بشه و فقط جاهایی که شما میخواید، قابل رویت باشه. مانند اسکین های Windows Media Player که بسیار زیباست.
یک پروژه جدید باز کنید و داخل فرمتون یک شئ Shape بذارید و کد زیر رو تو قسمت جنرال فرمتون کپی کنید :
Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Const LWA_COLORKEY = &H1
Const GWL_EXSTYLE = (-20)
Const WS_EX_LAYERED = &H80000
Const BM_SETSTATE = &HF3
Private Sub Form_Load()
Dim Ret As Long
Dim CLR As Long
Me.BackColor = RGB(1, 1, 1) ' تعیین رنگ پس زمینه فرم
CLR = Me.BackColor
Ret = GetWindowLong(Me.hWnd, GWL_EXSTYLE)
Ret = Ret Or WS_EX_LAYERED
SetWindowLong Me.hWnd, GWL_EXSTYLE, Ret
SetLayeredWindowAttributes Me.hWnd, CLR, 0, LWA_COLORKEY
End Sub
طرز کار : قسمتهای مشکی رنگ فرم رو حذف میکنه به همین سادگی حالا اگه بر حسب اتفاق شما مجبورید که از رنگ مشکی به عنوان پس زمینه فرمتون استفاده کنید باید در اون قسمتی که رنگ پس زمینه فرم تعیین میشه (به کد نگاه کنید) رنگ سفبد رو تعیین کنید یعنی Me.BackColor = RGB (255, 255, 255) به همین سادگی. در واقع این کد رنگی رو که شما تعیین میکنید رو از هر جای فرم حذف میکنه حتی اگه اون رنگ در وسط فرم باشه که در این صورت وسط فرم خالی میشه و هر چیزی که در پشت فرم قرار داره رو میشه از اون سوراخ دید. موفق باشید.
نظــــر بــــدهید...
یک پروژه جدید باز کنید و تو قسمت جنرال فرمتون کدهای زیر رو کپی کنید :
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Sub Command1_Click()
Dim Retval As Long
Retval = GetWindowLong(hWnd, -20)
Retval = Retval Or 524288
SetWindowLong hWnd, -20, Retval
SetLayeredWindowAttributes hWnd, 0, Val(Text1.Text), 2
End Sub
Private Sub Form_Load()
Text1.Text = 100
Command1_Click
End Sub
تو TextBox یک عدد از 0 تا 255 وارد کنید و کلید Command1 رو بزنید و شاهد شفاف شدن فرم باشید. فقط توجه داشته باشید که اگه از اعداد پایین مثل 1 استفاده کنید فرمتون تقریباً نامرئی میشه پس بهتون پیشنهاد میکنم تا حد امکان از اعداد بالای 50 استقاده کنید. موفق باشید.
نظــــر بــــدهید...
این کار با تابع BlockInput انجام میشه و تمام ورودیهای کامپیوتر رو قفل میکنه. توجه داشته باشید که سیستم عامل هنگ نمیکنه و به کار خودش ادامه میده امّا شما نمیتونید هیچ کاری انجام بدید به جز Restart کردن.
یک پروژه جدید باز کنید و کد زیر رو تو قسمت جنرال فرمتون کپی کنید :
Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub Form_Load()
BlockInput True
Sleep 5000
BlockInput False
End Sub
به محض شروع برنامه، تمام وروردیها به مدّت 5 ثانیه قفل میشن و بعد از اون دوباره به حالت اول برمیگردن. در اینجا تابع Sleep فقط برای اتلاف وقت به کار رفته و استفاده دیگه ای نداره. موفق باشید.
نظــــر بــــدهید...
با این کد فرم شما بر روی همه پنجره های قرار میگیره، مانند Windows Task Manager که همیشه رو قرار میگیره.
یک پروزه جدید باز کنید و کد زیر رو تو قسمت جنرال فرمتون کپی کنید :
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
Const SWP_NOACTIVATE = &H10
Const SWP_SHOWWINDOW = &H40
Private Declare Sub SetWindowPos Lib "User32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
Private Sub SetTopMost(frm As Form, ByVal blnMod As Boolean)
If blnMod Then
SetWindowPos frm.hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE
Else
SetWindowPos frm.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE
End If
End Sub
Private Sub Check1_Click()
Call SetTopMost(Me, Check1.Value)
End Sub
با علامت دار کردن CheckBox فرم همیشه رو قرار میگیره و با برداشتن علامت فرم به حالت عادی برمیگرده. موفق باشید.
نظــــر بــــدهید...
در این روش شما میتونید به هر کنترلی این مشخصه رو اعمال کنید، حتی کنترلهایی که فاقد این مشخصه هستند مثل DirListBox به صورت از راست به چپ در میان. درضمن اگه با فرمتون اینکارو بکنید میبینید که واقعاً به صورت از راست به چپ درمیاد یعنی دکمه Close، Minimize و Maximize از سمت راست فرم به سمت چپ فرم انتقال پیدا میکنن.
یک پروژه جدید باز کنید و یک DirListBox به فرمتون اضافه کنید و کد زیر رو تو قسمت جنرال فرمتون کپی کنید :
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Sub Form_Load()
SetWindowLong Me.hWnd, -20, GetWindowLong(Me.hWnd, -20) Or &H400000
SetWindowLong Dir1.hWnd, -20, GetWindowLong(Dir1.hWnd, -20) Or &H400000
End Sub
حالا برنامه رو اجرا کنید و شاهد تغییراتی که در حالت معمولی غیر ممکن بودن باشید. موفق باشید.
نظــــر بــــدهید...
اینکار که با توابع API به روش ویندوز انجام میشه، بهترین، مطمئن ترین، ساده ترین و سریع ترین روش برای درگ (Drag) کردنه فرمه. در ضمن در این روش بوسیله یک کنترل هم میشه فرم رو درگ کرد.
یک پروژه جدید باز کنید و توش یک Command Button و یک Label بذارید و کد زیر رو قسمت جنرال فرمتون کپی کنید :
Private Declare Function ReleaseCapture Lib "user32.dll" () As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lngReturnValue As Long
If Button = 1 Then
Call ReleaseCapture
lngReturnValue = SendMessage(Me.hWnd, &HA1, 2, 0&)
End If
End Sub
حالا یک بار بوسیله Label و یک بار هم بوسیله Command Button سعی کنید فرمتون رو درگ کنید. اگه بخواید بوسیله Label هم درگ بشه میتونید از کد داخل رویداد Command1_MouseMove برای رویداد Label1_MouseMove استفاده کنید به همین سادگی. موفق باشید.
نظــــر بــــدهید...
اینكار نه با توبع API و نه با كد نویسی امكان پذبر نیست چون محیط ویژوال بیسیك، محیط ویندوز 98 هست یعنی ذاتش ماله 98 و ویندوزهای قدیمیه ولی با استفاده از كدهای XML كه ربطی به وبلاگ من و مبحس ما نداره میشه یه كارایی كرد. از اسم XML حول نكنید هــا… فقط كافیه اونا رو همون طور كه در زیر نوشتم كپی كنید.
یعنی چی…؟
ببینید شما اولین كاری كه باید بكنید اینه كه برنامه Notepad رو باز كنید بعد كد زیر رو توش كپی كنید و برنامه رو با نام x.exe.MANIFEST ذخیره كنید. (x همون نام برنامتونه)
مثلاً فرض مكنیم فایل برنامه شما اسمش هست Project1.exe ، پس شما باید كدهای زیر رو توی Notepad كپی كنید و با نام Project1.exe.MANIFEST ذخیره كنید و فایل ذخیره شده (MANIFEST) رو در كنار فایل اجرایی تون قرار بدید و برنامتون رو اجرا كنید.
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
<assemblyIdentity
version="1.0.0.0"
processorArchitecture="X86"
name="Name"
type="win32"
/>
<dependency>
<dependentAssembly>
<assemblyIdentity
type="win32"
name="Microsoft.Windows.Common-Controls"
version="6.0.0.0"
processorArchitecture="X86"
publicKeyToken="6595b64144ccf1df"
language="*"
/>
</dependentAssembly>
</dependency>
</assembly>
به جای قسمتی كه پر رنگ شده (Name) نام برنامتون رو قرار بدید.
اما كارمون تموم نشده. مطمئناً اونقدر عجله داشتید كه تا اینجای آموزش رو نخوندید و رفتید سره وقته… حالا كه دیدید برنامه اجرا نمیشه (پیغام خطا میده) اومدید ادامه آموزش رو بخونید. بلــــــــه پیغام خطا میده، بچه بازی كه نیست…!
حالا چه كار كنیم كه پیغام خطا نده؟
آهـــــــا… ، اول پروژه برنامتون رو باز كنید (.vbp). حالا از منوی Project گزینه Components… رو انتخاب كنید و Microsoft Windows Common Control 5.0 رو علامت بزنید تا به پروژتون اضافه بشه. حالا یكی از كنترلهای اونو مثلاً StatusBar و یا كنترل ProgressBar رو به فرمی كه در اول اجرای برنامه نمایش داده میشه اضافه كنید. مثلاً اگر برنامه شما با Splash Screen شروع میشه باید یكی از این كنترلها رو درون فرمتون قرار بدید (Progress Bar بهتره) ولی اگه برناتون تنها یك فرم داره (فرم اصلی) باید یكی از این كنترلها رو به همون فرم اضافه كنید. توجه داشته باشید كه اینكار ضروریه. بعد از اینكار از برنامتون یك فایل اجرایی بگیرید و دوباره فایلش رو اجرا كنید. موفق باشید.
نظــــر بــــدهید...
خیلی از شما دوستان دنبال این کد هستید ولی پیدا نمیکنید، حق دارید پیدا نکنید چون این کد اون قدر طولانیه که هیچ کسی اونو تو وبلاگش نمیذاره. در ضمن من این کد رو خودم ننوشتم بلکه از اینترنت گرفتم ولی متأسفانه یادم نمیاد اسم سایتش چی بود امیدوارم که منو حلال کنه. خب حالا یک پروژه جدید باز کنید و از منوی Project گزینه ی Add Module رو انتخاب کنید تا یک Module به فرمتون اضافه بشه و بعد کد زیر رو توش کپی کنید :
Option Explicit
Private Const mcDayOff = 226894
Private mvarGDayTab
Private mvarJDayTab
Private mcSolar As Double
Public Sub GetJalaliDate(ByVal vGYear As Integer, ByVal vGMonth As Integer, ByVal vGDay As Integer, pJYear As Integer, pJMonth As Integer, pJDay As Integer, pDayName As String)
Dim mGTotalDay As Long
SetConstants
mGTotalDay = GetDayFromFirstGregorianDay(vGYear, vGMonth, vGDay)
pDayName = GetWeekDayName(mGTotalDay)
GetJalaliYearMonthDay mGTotalDay, vGYear, vGMonth, vGDay
pJDay = vGDay
pJMonth = vGMonth
pJYear = vGYear
End Sub
Private Sub SetConstants()
mvarGDayTab = Array(Array(0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31), Array(0, 31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31))
mvarJDayTab = Array(Array(0, 31, 31, 31, 31, 31, 31, 30, 30, 30, 30, 30, 29), Array(0, 31, 31, 31, 31, 31, 31, 30, 30, 30, 30, 30, 30))
mcSolar = 365.25 - 0.25 / 33
End Sub
Private Function GetDayFromFirstGregorianDay(ByVal vGYaer As Integer, ByVal vGMonth As Integer, ByVal vGDay As Integer) As Long
Dim mGYearDiv4 As Integer, mGYearDiv100 As Integer, mGYearDiv400 As Integer
Dim mGTotalDays As Long
mGYearDiv4 = vGYaer \ 4
mGYearDiv100 = vGYaer \ 100
mGYearDiv400 = vGYaer \ 400
mGTotalDays = GetGDayFromBeginOfYear(vGYaer, vGMonth, vGDay)
mGTotalDays = CLng(vGYaer - 1) * 365 + mGTotalDays + mGYearDiv4 - mGYearDiv100 + mGYearDiv400
GetDayFromFirstGregorianDay = mGTotalDays
End Function
Private Function GetGDayFromBeginOfYear(ByVal vGYear As Integer, ByVal vGMonth As Integer, ByVal vGDay As Integer) As Long
Dim mGLeap As Integer
Dim mCount As Integer
GetGDayFromBeginOfYear = vGDay
mGLeap = IsLeapGregorian(vGYear)
For mCount = 1 To vGMonth - 1
GetGDayFromBeginOfYear = GetGDayFromBeginOfYear + mvarGDayTab(mGLeap)(mCount)
Next mCount
End Function
Private Function IsLeapGregorian(ByVal vGYear As Integer) As Integer
If (vGYear Mod 4 = 0 And vGYear Mod 100 <> 0) Or (vGYear Mod 400 = 0) Then
IsLeapGregorian = 1
Else
IsLeapGregorian = 0
End If
End Function
Private Function GetJalaliYearMonthDay(vGTotalDay As Long, pJYear As Integer, pJMonth As Integer, pJDay As Integer)
Dim mJTotalDay As Long
Dim mJYear As Integer
Dim mJDay As Integer
Dim mJLeaps As Integer
mJTotalDay = vGTotalDay - mcDayOff
mJYear = mJTotalDay \ mcSolar
mJLeaps = GetAllJalaliLeapFromBegin(mJYear)
mJDay = mJTotalDay - (365 * CLng(mJYear) + mJLeaps)
mJYear = mJYear + 1
Do While mJDay <= 0
mJYear = mJYear - 1
If IsLeapJalali(mJYear) = 1 Then
mJDay = mJDay + 366
Else
mJDay = mJDay + 365
End If
Loop
If (mJDay = 366 And IsLeapJalali(mJYear) = 0) Then
mJDay = 1
mJYear = mJYear + 1
End If
pJYear = mJYear
GetJalaliMonthDay mJYear, mJDay, pJMonth, pJDay
End Function
Private Function IsLeapJalali(ByVal vJYear As Integer) As Integer
Dim mTemp As Integer
mTemp = vJYear Mod 33
If mTemp = 1 Or mTemp = 5 Or mTemp = 9 Or mTemp = 13 Or mTemp = 17 Or mTemp = 22 Or mTemp = 26 Or mTemp = 30 Then
IsLeapJalali = 1
Else
IsLeapJalali = 0
End If
End Function
Private Function GetAllJalaliLeapFromBegin(ByVal vJYear As Integer) As Integer
Dim mJLeap As Integer
Dim mCurrentCycle As Integer
Dim mJDiv33 As Integer
Dim mCount As Integer
Dim mTemp As Integer
mJDiv33 = vJYear \ 33
mCurrentCycle = vJYear - (mJDiv33 * 33)
mJLeap = mJDiv33 * 8
If mCurrentCycle > 0 Then
mTemp = IIf(mCurrentCycle <= 18, mCurrentCycle, 18)
For mCount = 1 To mTemp Step 4
mJLeap = mJLeap + 1
Next
End If
If mCurrentCycle > 21 Then
mTemp = IIf(mCurrentCycle <= 30, mCurrentCycle, 30)
For mCount = 22 To mTemp Step 4
mJLeap = mJLeap + 1
Next
End If
GetAllJalaliLeapFromBegin = mJLeap
End Function
Private Sub GetJalaliMonthDay(ByVal vJYear As Integer, ByVal vJDayOfYear As Integer, pJMonth As Integer, pJDay As Integer)
Dim mCount As Integer
Dim mJLeap As Integer
mJLeap = IsLeapJalali(vJYear)
mCount = 1
Do While vJDayOfYear > mvarJDayTab(mJLeap)(mCount)
vJDayOfYear = vJDayOfYear - mvarJDayTab(mJLeap)(mCount)
mCount = mCount + 1
Loop
pJMonth = mCount
pJDay = vJDayOfYear
End Sub
Private Function GetWeekDayName(DayFromBegin As Long) As String
Dim Temp As Integer
Temp = DayFromBegin Mod 7
Select Case Temp
Case 0
GetWeekDayName = "یك شنبه"
Case 1
GetWeekDayName = "دو شنبه"
Case 2
GetWeekDayName = "سه شنبه"
Case 3
GetWeekDayName = "چهار شنبه"
Case 4
GetWeekDayName = "پنج شنبه"
Case 5
GetWeekDayName = "جمعه"
Case 6
GetWeekDayName = "شنبه"
End Select
End Function
Public Sub GetGregorianDate(ByVal vJYear As Integer, ByVal vJMonth As Integer, ByVal vJDay As Integer, ByRef pGYear As Integer, ByRef pGMonth As Integer, ByRef pGDay As Integer, pDayName As String)
Dim mJTotalDays As Long
Dim mGYear As Integer
Dim mGMonth As Integer
Dim mGDay As Integer
SetConstants
mJTotalDays = GetDayFromFirstJalaliDay(vJYear, vJMonth, vJDay)
GetWeekDayName (mJTotalDays + mcDayOff)
GetGregorianYearMonthDay mJTotalDays, mGYear, mGMonth, mGDay
pGYear = mGYear
pGMonth = mGMonth
pGDay = mGDay
End Sub
Private Function GetDayFromFirstJalaliDay(ByVal vJYear As Integer, ByVal vJMonth As Integer, ByVal vJDay As Integer) As Long
Dim mJLeap As Integer
Dim mTemp As Integer
mJLeap = GetAllJalaliLeapFromBegin(vJYear - 1)
mTemp = GetJDayFromBeginOfYear(vJYear, vJMonth, vJDay)
GetDayFromFirstJalaliDay = CLng((vJYear - 1)) * 365 + mJLeap + mTemp
End Function
Private Function GetJDayFromBeginOfYear(ByVal vJYear As Integer, ByVal vJMonth As Integer, ByVal vJDay As Integer) As Integer
Dim mCount As Integer
Dim mJLeap As Integer
GetJDayFromBeginOfYear = vJDay
mJLeap = IsLeapJalali(vJYear)
For mCount = 1 To vJMonth - 1
GetJDayFromBeginOfYear = GetJDayFromBeginOfYear + mvarJDayTab(mJLeap)(mCount)
Next mCount
End Function
Private Sub GetGregorianYearMonthDay(vJTotalDays As Long, pGYear As Integer, pGMonth As Integer, pGDay As Integer)
Dim mGTotalDays As Long
Dim mGDiv4 As Integer
Dim mGDiv100 As Integer
Dim mGDiv400 As Integer
Dim mGDays As Integer
mGTotalDays = vJTotalDays + mcDayOff
pGYear = mGTotalDays \ mcSolar
mGDiv4 = pGYear \ 4
mGDiv100 = pGYear \ 100
mGDiv400 = pGYear \ 400
' Find Gregorian day of year
mGDays = mGTotalDays - (365 * CLng(pGYear)) - (mGDiv4 - mGDiv100 + mGDiv400)
pGYear = pGYear + 1
Do While mGDays <= 0
pGYear = pGYear - 1
If IsLeapGregorian(pGYear) = 1 Then
mGDays = mGDays + 366
Else
mGDays = mGDays + 365
End If
Loop
If (mGDays = 366 And IsLeapGregorian(pGYear) = 0) Then
mGDays = 1
pGYear = pGYear + 1
End If
GetGregorianMonthDay pGYear, mGDays, pGMonth, pGDay
End Sub
Private Sub GetGregorianMonthDay(ByVal vGYear As Integer, ByVal vGDayOfYear As Integer, pGMonth As Integer, pGDay As Integer)
Dim mCount As Integer
Dim mGLeap
mGLeap = IsLeapGregorian(vGYear)
mCount = 1
Do While vGDayOfYear > mvarGDayTab(mGLeap)(mCount)
vGDayOfYear = vGDayOfYear - mvarGDayTab(mGLeap)(mCount)
mCount = mCount + 1
Loop
pGMonth = mCount
pGDay = vGDayOfYear
End Sub
حالا کد زیر رو تو قسمت جنرال فرمتون کپی کنید :
Private Sub Form_Load()
Dim intYear As Integer, intMonth As Integer, intDay As Integer
Dim strDayName As String, strShamsi As String
GetJalaliDate Year(Date), Month(Date), Day(Date), intYear, intMonth, intDay, strDayName
strShamsi = intYear & "/" & intMonth & "/" & intDay & " " & strDayName
Me.Caption = strShamsi
End Sub
حالا برنامه رو اجرا کنید و از اون لذّت ببرید. موفق باشید.
اینم سورس برنامه (فقط ماژول) (حجم ۲ کیوبایت)
نظــــر بــــدهید...