تبلیغات


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

(بستن)

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

آرشیو موضوعی

لینکدونی

آرشیو

لینکستان

آمار در میهن بلاگ

  • کل بازدید :
  • بازدید امروز :
  • بازدید دیروز :
  • بازدید این ماه :
  • بازدید ماه قبل :
  • تعداد نویسندگان :
  • تعداد کل پست ها :
  • آخرین بازدید :
  • آخرین بروز رسانی :

سخن مدیر

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

تبادل بنر تبلیغاتی تبادل لوگوی وبلاگ

کلاسهای آموزش برنامه نویسی :

VB6 - VB.NET - C - C# - ASP - ASP.NET - PHP - SQL

به صورت خصوصی در مشهد با قیمت جلسه ای 15 هزار تومان - (حرفه ای شوید)

جهت کسب اطلاعات بیشتر با شماره 09364222771 تماس بگیرید

نظــــر = شخصیّــت Smiley


مرجع كامل مستند

تحلیلگر عبارت - محاسبه عبارت ریاضی (Sentence Analizer)

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


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

دانلود (حجم : 11 کیلوبایت)

موفق و پیروز باشید.


نظــــر بــــدهید...

بدست آوردن درایوهای منطقی سیستم (My Drives)

سلام دوستان عزیز.
احتمالا تا حالا براتون پیش اومده که برای یک کار خاص مثلا چک کردن وضعیت فایل 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 قرار دادیم با این کار یک آرایه درست میشه که تو هر خونه نام یک درایو قرار گرفته.

موفق و پیروز باشید.


نظــــر بــــدهید...

سورس نرم افزار بازدارنده ویروس (Virus Stoper)

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

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

دانلود سورس حجم فایل ۳۲۱۹ کیلوبایت

موفق و پیروز باشید.


نظــــر بــــدهید...

طرز کار USB Disk Security و ساخت پوشه AUTORUN.INF (ساخت پوشه با نامهای غیر مجاز)

سلام دوستان. این ترفندی که امروز میخوام آموزش بدم خیلی جالب و کاربردی هست ولی این ترفند هیچ ارتباطی با برنامه نویسی نداره بلکه به سیستم عامل مربوط میشه.
احتمالا تمام شما دوستان عزیز با نرم افزار 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 چی هست و چه کار میکنه ؟ فرض کنید میخواید برنامه ای بنویسید که زمانیکه اجرا میشه یه آهنگ پخش بشه و میخواید که این آهنگ از درون خود برنامه پخش بشه نه از داخل هارد! اینجاست که باید آهنگ رو تو یه فایل قرار بدید که اون فایل رو بهش res میگن که مخفف Resource هست. همین اول بگم که کار کردن با فایل res هیچ کای نداره حتی از درست کرن نیمرو هم آسونتره.

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

ابتدا شما باید برنامه VB Resource Editor رو به ویژوال بیسیک اضافه کنید که برای اینکار ویژوال بیسیک رو باز کنید و از منوی Add-Ins گزینه Add-in Manager رو انتخاب کنید که شکل زیر ظاهر میشه و شما باید مطابق شکل گزینه VB 6 Resource Editor رو انتخاب کنید و در پایین پینجره در سمت راست گزینه های Loaded/Unloaded و همچنین Load on Startup رو علامت بزنید و کلیک OK رو بزنید.

Add-In Manager

حالا در منوی Standard یک گزینه به آخر منو اضافه میشه که آیکون مکعب سبز هست مثل شکل زیر.

Standard Menu

حالا باید یک پروژه جدید باز کنید (کلید Ctrl + N رو بزنید و بعد OK).  حالا روی آیکون مکعب کلیک کنید تا پنجره VB Resource Editor باز بشه. شکل زیر.
در منوی این پنجره چندین آیکون وجود داره که از شکلشون معلومه چی هستن. شما میتونید در این قسمت هر فایلی رو که میخواید اضافه کنید. در منوی برنامه چند گزینه برای اینکار وجود داره که به ترتیب برای اضافه کردن اشاره گر موس ، اضافه کردن آیکون ، اضافه کردن عکس و اضافه کردن هر نوع فایل به کار میروند.

VB Resource Editor

چون ما میخوایم یک آهنگ به فایل res اضافه کنیم پس باید آخرین گزینه یعنی Add Custom Resource رو بزنیم و فایل خودمون رو اضافه کنیم. بعد افزودن فایل باید روی دکمه Save کلیک کنید و فایل res رو یه جایی ذخیره کنید. به شکل زیر توجه کنید.

بعد از افزودن فایل، یک پوشه به نام CUSTOM ایجاد میشه و در داخل اون فایلتون با شماره پیشفرض 101 اضافه میشه که خودتون میتونید اونو در قسمت Properties تغییر بدید که ما اینکارو نمیکنیم و از همون نام پیشفرض استفاده میکنیم. بعد از Save کردن فایل به طور اتوماتیک باید فایل RES به قسمت Project اضافه بشه. شکل زیر.

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 Radio [24 kbps]

PB Radio [96 kbps]

PMC رادیو

رادیو زمانه

PB Rap Radio [PersianRap Only]

Radio France Persian


نظــــر بــــدهید...

کتاب های الکترونیکی آموزشی

سلام دوستان امروز براتون چند تا کتاب آموزشی دارم.

آموزش ویژوال بیسیک (خودم) دانلود (۳۳۹ کیلو بایت)

آموزش 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 پیدا کنید.


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


نظــــر بــــدهید...

بدست آوردن كد RGB رنگ مورد نظر

یك پروژه جدید باز كنید و یك شی 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 كامپیوتر شما داره، برای من كه سریع ترسیم میشه. موفق باشید.


نظــــر بــــدهید...

Stretch کردن تصاویر در PictureBox و Form

درسته كه 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

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


نظــــر بــــدهید...

پر كردن فضاهای خالی با رنگ مورد نظر (API)

حالا این كه گفتم چی هست؟ مثلاً یه دایره رو در نظر بگیرید كه توش خالیه و میخوایم توشو با رنگ آبی پر كنیم، اینجاست كه این تابع به دردمون میخوره. این تابع بیشتر بدرد بچه های سوم كامپیوتر كه میخوان برنامه 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

كدی كه شاید خیلی از شما دوستان دنبالش هستید و من خودمم خیلی وقت بود كه دنبالش میگشتم، بدست آوردن آدرس بار در 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 رو بزنید، میبینید که شماره گیری توسط خود ویندوز انجام میشه و احتیاجی نیست که شما کاری انجام بدید. موفق باشید.


نظــــر بــــدهید...

پخش فایلهای MP3 با برنامه شما

اصل کدش رو از تو یه سورس آماده یاد گرفتم و برای شما عزیزان گذاشتم تا نظرای خوب خوب بدید. یک پروژه جدید باز کنید و تو فرمتون یک 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 کپی کنیم که روش جالبی نیست چون کاربر میتونه بره به اون پوشه و فایل رو پاک کنه و امّا روش دوّم (قابل توجّه ویروس نویسا) اینه که برنامه رو تو لیست برنامه های 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 جای کلیک چپ و راست موس رو عوض کنید. به همین سادگی. موفق باشید.


نظــــر بــــدهید...

بستن برنامه ها یا همون End Task کردن برنامه ها

براین بستن برنامه ها باید بدونید که عنوان (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 فقط برای اتلاف وقت به کار رفته و استفاده دیگه ای نداره. موفق باشید.


نظــــر بــــدهید...

قرار دادن فرم بر روی تمام پنجره ها (خاصیت Always On Top برای فرم)

با این کد فرم شما بر روی همه پنجره های قرار میگیره، مانند 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 فرم همیشه رو قرار میگیره و با برداشتن علامت فرم به حالت عادی برمیگرده. موفق باشید.


نظــــر بــــدهید...

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

در این روش شما میتونید به هر کنترلی این مشخصه رو اعمال کنید، حتی کنترلهایی که فاقد این مشخصه هستند مثل 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 استفاده کنید به همین سادگی. موفق باشید.


نظــــر بــــدهید...

دادن تم ویندوز به برنامه (XP، Vista، و …)

اینكار نه با توبع 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

حالا برنامه رو اجرا کنید و از اون لذّت ببرید. موفق باشید.


اینم سورس برنامه (فقط ماژول) (حجم ۲ کیوبایت)


نظــــر بــــدهید...

 
  • تعداد صفحات :2
  • 1  
  • 2  
 

درباره وبلاگ

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

آخرین پست ها

جستجو

نویسندگان

آمار در وبگذر

Page Rank