مدیریت مینودشت زیبا

((افتادگی آموز اگر طالب فیضی     هرگز نخورد آب زمینی که بلند است))

در این وبلاگ به مسائل آموزشی پرداخته می شود و همه جور آموزشی هست

در این هفته قصد آموزش زبان برنامه نویسی ویژوال بیسیک رو دارم

امیدوارم مطالب این وبلاگ بدردتون بخوره

تقدیم به همه بروبچ مینودشت

حمید رضا سهیلی

اختصاص پسوند فایلها به برنامه (مبحث مهم)

خوب اول بذارید با یه مقدمه درس رو شروع کنم تا مطلب رو بهتر بگیرید، شما ها همتون خوب میدونید که وقتی روی یک تصویر (Jpeg یا bmp یا GIF و یا غیره) دوبار کلیک می کنید نرم افزار Preview که مخصوص ویندوزه اجرا میشه و تصویر رو نشون میده.

حالا ما میخوایم بدونیم که چطوری این اتفاق میفته؟ یعنی اگه ما بخوایم یک نرم افزار مثل Preview یا Notepad بسازیم که با دوبار کلیک روی فایل، برنامه ما به اجرا در بیاد، باید چه کار کنیم؟

امّا عجله نکنید من برای این مشکل که مبحث مهمّی هم هست یک جواب پیدا کردم ولی یه خواهشی ازتون دارم اگه این آموزش رو تا تهش خوندید و براتون مفید بود حتماً نظر بدید در ضمن، نپرسید که درباره خط فلان یکم توضیح بده. آخه توضیح رو میخوای چه کار؟ کد رو بردار استفاده کن دیگــــــه.

یک پروژه جدید باز کنید و توش یک شئ Image بذارید و کد زیر رو تو قسمت جنرال فرمتون کپی کنید :

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 RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Sub SHChangeNotify Lib "shell32.dll" (ByVal wEventId As Long, ByVal uFlags As Long, dwItem1 As Any, dwItem2 As Any)

Private Sub Form_Load()
    Image1.Stretch = True
    Image1.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight
    '
    RegisterFile ".BMP"
    RegisterFile ".JPG"
    RegisterFile ".GIF"
    RegisterFile ".WMF"
    RegisterFile ".EMF"
    '
    On Error Resume Next
    If Len(Command()) > 0 Then
        Image1.Picture = LoadPicture(FixPath(Command()))
    End If
End Sub

Private Sub RegisterFile(strPasvand As String)
    Dim sKeyName As String   ' Holds Key Name in registry.
    Dim sKeyValue As String  ' Holds Key Value in registry.
    Dim ret&           ' Holds error status if any from API calls.
    Dim lphKey&        ' Holds  key handle from RegCreateKey.
    Dim path As String
   
    path = App.path
    If Right(path, 1) <> "\" Then
       path = path & "\"
    End If
   
    ' This creates a Root entry called "PicturePreview".
    sKeyName = "PicturePreview" ' Project Name
    sKeyValue = "Picture"
    ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
    ret& = RegSetValue&(lphKey&, "", REG_SZ, sKeyValue, 0&)
   
    ' This creates a Root entry called .BMP;.JPG;.GIF;.WMF associated with "PicturePreview".
    sKeyName = strPasvand
    sKeyValue = "PicturePreview" ' Project Name
    ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
    ret& = RegSetValue&(lphKey&, "", REG_SZ, sKeyValue, 0&)
   
    ' This sets the command line for "PicturePreview".
    sKeyName = "PicturePreview" ' Project Name
    sKeyValue = path & App.EXEName & ".exe %1"
    ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
    ret& = RegSetValue&(lphKey&, "shell\open\command", REG_SZ, sKeyValue, MAX_PATH)
   
    ' This sets the icon for the file extension
    sKeyName = "PicturePreview" ' Project Name
    sKeyValue = path & "MyIcon.ico"
    ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
    ret& = RegSetValue&(lphKey&, "DefaultIcon", REG_SZ, sKeyValue, MAX_PATH)
   
    ' This notifies the shell that the icon has changed
    SHChangeNotify SHCNE_ASSOCCHANGED, SHCNF_IDLIST, 0, 0
End Sub

Public Function FixPath(strPath As String) As String
    Dim strTemp As String
    strTemp = strPath
    strChar = """"
    If Len(strTemp) > 0 Then
        If Mid(strTemp, 1, 1) = strChar Then strTemp = Right(strTemp, Len(strTemp) - 1)
        If Mid(strTemp, Len(strTemp), 1) = strChar Then strTemp = Left(strTemp, Len(strTemp) - 1)
    End If
    FixPath = strTemp
End Function

خوب حالا از برنامتون یک فایل اجرایی (.exe) بسازید و همچنین یک آیکون که بیانگر فایلهای تصویری باشه با نام MyIcon.ico کنار فایل اجرایی که ساختبد قرار بدید.

توجّه : این آیکون (MyIcon.ico) همیشه بایددر کنار  فایل اجرایی برنامتون باشه، در غیر اینصورت شکل فایلهای تصویری که قراره با برنامه شما باز بشن به شکل فایلهای ناشناخته در میاد.

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

بعد از یک بار اجرا کردن و بستن برنامه، برید روی یکی از عکسهاتون دابل کلیک کنید که دو حالت پیش میاد : 1- برنامه شما اجرا میشه و عکس رو نشون میده.  2- کادر محاوره ای Open with... باز میشه و از شما میخواد که برنامه مورد نظرتون رو برای نمایش عکس انتخاب کنید؛ حالا کاری که شما باید بکنید اینه که به آدرس برنامتون برید و برنامه خودتونو برای نمایش عکس انتخاب کنید تا از این به بعد همیشه عکسها با برنامه شما باز بشن.

شما میتونید اینکارو برای پسوند هر فایلی انجام بدید، مثلاً میتونید پسوند .txt رو تعریف کنید و با گذاشتن یک TextBox تو فزمتون یک برنامه Notepad بسازید. به همین سادگی. موفق باشید.

اعمال مشخصه 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

حالا برنامه رو اجرا کنید و شاهد تغییراتی که در حالت معمولی غیر ممکن بودن باشید. موفق باشید.

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

قفل کردن تمام ورودی ها مثل Keyboard و Mouse

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

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

یک پروژه جدید باز کنید و تو قسمت جنرال فرمتون کدهای زیر رو کپی کنید :

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 استقاده کنید. موفق باشید.

نامرئی کردن قسمتهای اضافی فرم (برای گذاشتن اسکین خوبه)

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

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

تعویض کلیک چپ و راست موس

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

قرار دادن برنامه در 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

اگه برنامه اجرا بشه، مسیر فایل اجرایی برنامه در رجیستری ذخیره شده و در هر بار اجرای برنامه همراه برنامه های دیگه اجرا میشه. به همین سادگی. موفق باشید.

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

ورود شما را به این وبلاگ خوش آمد می گویم

افتادگی آموز اگر طالب فیضی  ***  هرگز نخورد آب زمینی که بلند است

امید وارم لحظات خوبی را در این وبلاگ سپری کنید

کوچک شما حمیدرضا سهیلی

به افتخار همه بروبچ(( مینودشتی))

به زودی مطالب زیادی اظافه خواهم کرد

شهرستان مینودشت یکی از شهرستانهای استان گلستان ایران است. شهر مینودشت مرکز این شهرستان است و جمعیت آن در سال ۱۳۸۵، برابر با ۱۲۸٫۷۳۹ نفر بوده است ^[۱].

 تقسیمات کشوری

• شهرها: مینودشت و گالیکش.

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

شهر: مینودشت

• بخش گالیکش
  • دهستان قراولان
  • دهستان نیلکوه
  • دهستان ینقاق

شهر: گالیکش

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

در این وبلاگ به مطالب آموزشی پرداخته می شود  همه جور آموزشی هست

می خواهم در اولین قسمت از وبلاگم آموزش برنامه نویسی با زبان ویژوال بیسیک رو یاد بدم

تغيير روشنايي تصوير

اينكار با استفاده از آموزش بالا (بدست آوردن كد 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 كامپيوتر شما داره، براي من كه سريع ترسيم ميشه. موفق باشيد.

شبیه سازی برنامه Paint

این برنامه تقریباً کاره برنامه Paint رو انجام میده امّا کامل نیست که خودتون میتونید تکمیلش کنید، من فقط اساس کارو بهتون آموزش میدم.

یک پروژه جدید باز کنید و دو تا منو به نامهای mnuClear و mnuSave درست كنيد و Caption اونارو بذارید Clear و Save بعد کد زیر رو تو قسمت جنرال فرمتون کپی کنید:

Dim sngOldX, sngOldY As Single

Private Sub Form_Load()
    Me.Appearance = 0
    Me.AutoRedraw = True
    Me.DrawWidth = 3
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
        If Button = vbRightButton Then
            Me.ForeColor = RGB(Rnd * 255, Rnd * 255, Rnd * 255)
        End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
        If Button = vbLeftButton Then
            Me.Line (sngOldX, sngOldY)-(X, Y)
        End If
        sngOldX = X
        sngOldY = Y
End Sub

Private Sub mnuClear_Click()
    Me.Cls
End Sub

Private Sub mnuSave_Click()
    SavePicture Me.Image, "C:\Pic.bmp"
    MsgBox ("C:\Pic.bmp")
End Sub

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

 

ساخت Link برای سایت یا وبلاگ (درخواستی)

یک پروژه جدید باز کنید و توش یک Label بزارید و کدهای زیر رو تو قسمت جنرال فرمتون کپی کنید :

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Sub Form_Load()
    Label1.Caption = "www.v-basic.mihanblog.com"
End Sub

Private Sub Label1_Click()
    Link Label1.Caption
End Sub

Public Function Link(ByVal URL As String) As Long
    Link = ShellExecute(0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus)
End Function

حالا برنامتون رو اجرا كنيد و روي Label كليك كنيد تا وارد سايت مربروطه بشه، به همين سادگي. موفق باشید.

تبدیل تاریخ میلادی به تاریخ شمسی

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

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

ساعت عقربه ای (آنالوگ)

یک پروژه جدید باز کنید و تو فرمتون یک Timer بذارید و Interval اونو 1000 بذارید، حالا کد زیر رو تو قسمت جنرال فرمتون کپی کنید :

Private Sub Form_Load()
    Me.BackColor = vbBlack
End Sub

Private Sub Timer1_Timer()
    Form1.Refresh
    X = Form1.Width / 2
    Y = Form1.Height / 2.2
    Circle (X, Y), Y - 200, vbWhite
    Circle (X, Y), Y - 220, vbWhite
    For i = 1 To 12
        Circle (X + (Y - 400) * Cos(i * 22 / 42), Y + (Y - 400) * Sin(i * 22 / 42)), 50, vbRed
    Next
    h = Hour(Time())
    If h > 12 Then
        h = h – 12
    End If
    m = Minute(Time())
    s = Second(Time())
    Line (X, Y)-(X + (Y - 600) * Cos((66 / 14 + s * (44 / 420))), Y + (Y - 600) * Sin((66 / 14 + s * (44 / 420)))), vbBlue
    Line (X, Y)-(X + (Y - 800) * Cos((66 / 14 + m * (44 / 420))), Y + (Y - 800) * Sin((66 / 14 + m * (44 / 420)))), vbYellow
    Line (X, Y)-(X + (Y - 1200) * Cos(66 / 14 + h * (44 / 84) + (m / 12) * (44 / 420)), Y + (Y - 1200) * Sin(66 / 14 + h * (44 / 84) + (m / 12) * (44 / 420))), vbWhite
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 استفاده کنید به همین سادگی. موفق باشید.

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

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

یک پروژه جدید باز کنید و تو قسمت جنرال فرمتون کدهای زیر رو کپی کنید :

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 استقاده کنید. موفق باشید