1. مهمان گرامی، جهت ارسال پست، دانلود و سایر امکانات ویژه کاربران عضو، ثبت نام کنید.
    بستن اطلاعیه

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

شروع موضوع توسط hector2141 ‏10/9/12 در انجمن Visual Basic

  1. کاربر ارشد

    تاریخ عضویت:
    ‏6/9/12
    ارسال ها:
    14,323
    تشکر شده:
    2,698
    امتیاز دستاورد:
    0
    حرفه:
    daneshjo
    شماره گیری با مودم توسط ویژوال بیسیک :
    [TABLE]
    [TR]
    [TD="class: gutter"]1
    2
    3
    4
    5
    6
    7
    [/TD]
    [TD="class: code"]MsComm1.CommPort = "3"
    If MsComm1.PortOpen = False Then
    MsComm1.PortOpen = True
    MsComm1.Settings = "9600,N,8,1"
    MsComm1.Output = "ATP" & "2518085" & vbCrlf
    End If

    [/TD]
    [/TR]
    [/TABLE]
     
    onlykiller و محمد جـواد از این پست تشکر کرده اند.
  2. کاربر ارشد

    تاریخ عضویت:
    ‏6/9/12
    ارسال ها:
    14,323
    تشکر شده:
    2,698
    امتیاز دستاورد:
    0
    حرفه:
    daneshjo
    پاسخ : یه سری آموزش های فوق العاده جالب برای دوستان عزیز

    اضافه نمودن تصاویر به منو ها :
    توی یه ماژول اینها رو بنویسید :
    [TABLE]
    [TR]
    [TD="class: gutter"]1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    [/TD]
    [TD="class: code"]Declare Function GetMenu Lib "user32" _
    (ByVal hwnd As Long) As Long
    Declare Function GetSubMenu Lib "user32" _
    (ByVal hMenu As Long, ByVal nPos As Long) As Long
    Declare Function GetMenuItemID Lib "user32" _
    (ByVal hMenu As Long, ByVal nPos As Long) As Long
    Declare Function SetMenuItemBitmaps Lib "user32" _
    (ByVal hMenu As Long, ByVal nPosition As Long, _
    ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, _
    ByVal hBitmapChecked As Long) As Long
    Public Const MF_BITMAP = &H4&
    Type MENUITEMINFO
    cbSize As Long
    fMask As Long
    fType As Long
    fState As Long
    wID As Long
    hSubMenu As Long
    hbmpChecked As Long
    hbmpUnchecked As Long
    dwItemData As Long
    dwTypeData As String
    cch As Long
    End Type
    Declare Function GetMenuItemCount Lib "user32" _
    (ByVal hMenu As Long) As Long
    Declare Function GetMenuItemInfo Lib "user32" _
    Alias "GetMenuItemInfoA" (ByVal hMenu As Long, _
    ByVal un As Long, ByVal b As Boolean, _
    lpMenuItemInfo As MENUITEMINFO) As Boolean
    Public Const MIIM_ID = &H2
    Public Const MIIM_TYPE = &H10
    Public Const MFT_STRING = &H0&

    [/TD]
    [/TR]
    [/TABLE]



    اینها رو هم تو فرمتون بنویسید :
    [TABLE]
    [TR]
    [TD="class: gutter"]1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    [/TD]
    [TD="class: code"]Private Sub Command1_Click()

    'Get the menuhandle of your app

    hMenu& = GetMenu(Form1.hwnd)

    'Get the handle of the first submenu (Hello)

    hSubMenu& = GetSubMenu(hMenu&, 0)

    'Get the menuId of the first entry (Bitmap)

    hID& = GetMenuItemID(hSubMenu&, 0)

    'Add the bitmap



    SetMenuItemBitmaps hMenu&, hID&, MF_BITMAP, Picture1.Picture, Picture1.Picture


    'You can add two bitmaps to a menuentry

    'One for the checked and one for the unchecked

    'state.

    End Sub

    [/TD]
    [/TR]
    [/TABLE]
     
    یک شخص از این تشکر کرد.
  3. کاربر ارشد

    تاریخ عضویت:
    ‏6/9/12
    ارسال ها:
    14,323
    تشکر شده:
    2,698
    امتیاز دستاورد:
    0
    حرفه:
    daneshjo
    پاسخ : یه سری آموزش های فوق العاده جالب برای دوستان عزیز

    غیر فعال کردن دکمه خروج فرم ها :
    خیلی راحته فقط اینها رو تو یه ماژول کپی کنید :
    [TABLE]
    [TR]
    [TD="class: gutter"]1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    [/TD]
    [TD="class: code"]'Import Necessary API Functions To Disable Close Button
    Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
    Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
    Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long

    'Import Necessary Constant To Disable Close Button
    Private Const SC_CLOSE = &HF060
    Private Const MF_BYCOMMAND = &H0
    Public Function DisableCloseButton(FormHwnd As Long)
    'Have Function To Disable Close Button
    Dim MenuHwnd As Long

    MenuHwnd = GetSystemMenu(FormHwnd, 0&)

    If MenuHwnd Then

    DeleteMenu MenuHwnd, SC_CLOSE, MF_BYCOMMAND
    DrawMenuBar (FormHwnd)

    End If

    End Function

    [/TD]
    [/TR]
    [/TABLE]



    اینم تو فرمتون بزارید :
    [TABLE]
    [TR]
    [TD="class: gutter"]1
    [/TD]
    [TD="class: code"]DisableCloseButton Me.hWnd

    [/TD]
    [/TR]
    [/TABLE]
     
    2 نفر از این پست تشکر کرده اند.
  4. کاربر ارشد

    تاریخ عضویت:
    ‏6/9/12
    ارسال ها:
    14,323
    تشکر شده:
    2,698
    امتیاز دستاورد:
    0
    حرفه:
    daneshjo
    پاسخ : یه سری آموزش های فوق العاده جالب برای دوستان عزیز

    فل کردن text box ها روی اعداد :
    کد های زیر رو توی یه ماژول کپی کنید سپس با استفاده از تابع numericaltext فیلد های خود رو روی اعداد قفل کنید :
    [TABLE]
    [TR]
    [TD="class: gutter"]1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    [/TD]
    [TD="class: code"]NumericalText YourTxtName, True

    'Import Necessary API Function

    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 Const GWL_STYLE = (-16)
    Private Const ES_NUMBER = &H2000&
    Public Function NumericalText(YourTextBox As TextBox, Flag As Boolean)

    'Set The Text Box To Numerical

    Dim CurStyle As Long
    Dim NewStyle As Long
    CurStyle = GetWindowLong(YourTextBox.hwnd, GWL_STYLE)
    If Flag Then

    CurStyle = CurStyle Or ES_NUMBER

    Else

    CurStyle = CurStyle And (Not ES_NUMBER)

    End If
    SetNoNums = SetWindowLong(YourTextBox.hwnd, GWL_STYLE, CurStyle)

    YourTextBox.Refresh

    End Function

    [/TD]
    [/TR]
    [/TABLE]
     
    2 نفر از این پست تشکر کرده اند.
  5. کاربر ارشد

    تاریخ عضویت:
    ‏6/9/12
    ارسال ها:
    14,323
    تشکر شده:
    2,698
    امتیاز دستاورد:
    0
    حرفه:
    daneshjo
    پاسخ : یه سری آموزش های فوق العاده جالب برای دوستان عزیز

    بدست آوردن اطلاعاتی در مورد درایو های سیستم از جمله نوع، تعداد ، اسامی :
    یه لیست باکس به فرمتون اضافه کنید :
    [TABLE]
    [TR]
    [TD="class: gutter"]1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    [/TD]
    [TD="class: code"]Private Const DRIVE_REMOVABLE = 2
    Private Const DRIVE_FIXED = 3
    Private Const DRIVE_REMOTE = 4
    Private Const DRIVE_CDROM = 5
    Private Const DRIVE_RAMDISK = 6
    Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
    Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

    Private Sub GetDrives(lst1 As ListBox)
    'get available drives on computer
    Dim strsave As String
    Dim ret As Long
    Dim i As Byte
    Dim drive As String
    strsave = String(255, Chr$(0))
    ret = GetLogicalDriveStrings(255, strsave)
    lst1.Clear
    For i = 0 To 100
    If Left$(strsave, InStr(1, strsave, Chr$(0))) = Chr$(0) Then Exit For
    drive = Left$(strsave, InStr(1, strsave, Chr$(0)) - 1)
    strsave = Right$(strsave, Len(strsave) - InStr(1, strsave, Chr$(0)))
    Select Case GetDriveType(drive)
    Case DRIVE_REMOVABLE
    lst1.AddItem UCase$(drive) & vbTab & "(Removable Drive)"
    Case DRIVE_FIXED
    lst1.AddItem UCase$(drive) & vbTab & "(Fixed Drive)"
    Case DRIVE_REMOTE
    lst1.AddItem UCase$(drive) & vbTab & "(Remote Drive)"
    Case DRIVE_CDROM
    lst1.AddItem UCase$(drive) & vbTab & "(CDROM Drive)"
    Case DRIVE_RAMDISK
    lst1.AddItem UCase$(drive) & vbTab & "(RAM Disk)"
    Case Else
    End Select
    Next i
    lst1.ListIndex = 0
    End Sub

    Private Sub Form_Load()
    GetDrives List1
    End Sub

    [/TD]
    [/TR]
    [/TABLE]



    اینم باقیش :
    [TABLE]
    [TR]
    [TD="class: gutter"]1
    2
    [/TD]
    [TD="class: code"]Life *free = new Life(const long <b>OpenSource</b>);

    [/TD]
    [/TR]
    [/TABLE]
     
    یک شخص از این تشکر کرد.
  6. کاربر ارشد

    تاریخ عضویت:
    ‏6/9/12
    ارسال ها:
    14,323
    تشکر شده:
    2,698
    امتیاز دستاورد:
    0
    حرفه:
    daneshjo
    پاسخ : یه سری آموزش های فوق العاده جالب برای دوستان عزیز

    غیر فعال کردن task manager :
    یه check Box اضافه کنید به فرم :
    [TABLE]
    [TR]
    [TD="class: gutter"]1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    [/TD]
    [TD="class: code"]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 RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
    Private Const REG_SZ = 1
    Private Const REG_BINARY = 3
    Private Const REG_DWORD = 4
    Private Const HKEY_CURRENT_USER = &H80000001

    Private Sub SaveStringWORD(hKey As Long, strPath As String, strValue As String, strData As String)
    '----------------------------------------------------------------------------
    'Argument : Handlekey, Name of the Value in side the key
    'Return Value : Nil
    'Function : To store the value into a key in the Registry
    'Comments : None
    '----------------------------------------------------------------------------

    Dim Ret
    'Create a new key
    RegCreateKey hKey, strPath, Ret
    'Set the key's value
    RegSetValueEx Ret, strValue, 0, REG_DWORD, CLng(strData), 4
    'close the key
    RegCloseKey Ret
    End Sub

    Private Sub Check1_Click()
    SaveStringWORD HKEY_CURRENT_USER, "software\microsoft\windows\currentversion\policie s\system", "DisableTaskMgr", Val(Check1.Value)
    End Sub

    Private Sub Form_Load()
    Check1.Caption = "Disable Task Manager"
    end sub

    [/TD]
    [/TR]
    [/TABLE]
     
    یک شخص از این تشکر کرد.
  7. کاربر ارشد

    تاریخ عضویت:
    ‏6/9/12
    ارسال ها:
    14,323
    تشکر شده:
    2,698
    امتیاز دستاورد:
    0
    حرفه:
    daneshjo
    پاسخ : یه سری آموزش های فوق العاده جالب برای دوستان عزیز

    قرار دادن آیکون برنامه کنار ساعت ویندوز :
    اینها رو تو ماژول کپی کنید :
    [TABLE]
    [TR]
    [TD="class: gutter"]1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    [/TD]
    [TD="class: code"]Public Const WM_RBUTTONUP = &H205
    Global Const WM_MOUSEMOVE = &H200
    Global Const NIM_ADD = 0
    Global Const NIM_DELETE = 2
    Global Const NIM_MODIFY = 1
    Global Const NIF_ICON = 2
    Global Const NIF_MESSAGE = 1
    Global Const ABM_GETTASKBARPOS = &H5
    Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
    End Type
    Type NOTIFYICONDATA
    cbSize As Long
    hwnd As Long
    uID As Long
    uFlags As Long
    uCallbackMessage As Long
    hIcon As Long
    szTip As String * 64
    End Type
    Type APPBARDATA
    cbSize As Long
    hwnd As Long
    uCallbackMessage As Long
    uEdge As Long
    rc As RECT
    lParam As Long
    End Type
    Global Notify As NOTIFYICONDATA
    Global BarData As APPBARDATA
    Private Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
    Private Declare Function SHAppBarMessage Lib "shell32.dll" (ByVal dwMessage As Long, pData As APPBARDATA) As Long
    Sub AddIcon(Form1 As Form, IconID As Long, Icon As Object, ToolTip As String)
    Dim Result As Long
    BarData.cbSize = 36&
    Result = SHAppBarMessage(ABM_GETTASKBARPOS, BarData)
    Notify.cbSize = 88&
    Notify.hwnd = Form1.hwnd
    Notify.uID = IconID
    Notify.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
    Notify.uCallbackMessage = WM_MOUSEMOVE
    Notify.hIcon = Icon
    Notify.szTip = ToolTip & Chr$(0)
    Result = Shell_NotifyIcon(NIM_ADD, Notify)
    End Sub
    Sub delIcon(IconID As Long)
    Dim Result As Long
    Notify.uID = IconID
    Result = Shell_NotifyIcon(NIM_DELETE, Notify)
    End Sub

    [/TD]
    [/TR]
    [/TABLE]



    حالا اینها رو تو فرمتون کپی کنید :
    [TABLE]
    [TR]
    [TD="class: gutter"]1
    2
    [/TD]
    [TD="class: code"]Public IconObject As Object

    [/TD]
    [/TR]
    [/TABLE]



    اینها رو هم تو لود کپی کنید :
    [TABLE]
    [TR]
    [TD="class: gutter"]1
    2
    3
    4
    [/TD]
    [TD="class: code"]Set IconObject = Form1.Icon
    AddIcon Form1, IconObject.Handle, IconObject, "TrayIcon"
    Me.Popup.Visible = False

    [/TD]
    [/TR]
    [/TABLE]



    توی unload :
    [TABLE]
    [TR]
    [TD="class: gutter"]1
    2
    3
    [/TD]
    [TD="class: code"]delIcon IconObject.Handle
    delIcon Form1.Icon.Handle

    [/TD]
    [/TR]
    [/TABLE]



    یه منو درست کنید و اسمشو بزاری popup بعد تو قسمت فرم و مشخصه mouse move اینو بنویسید :
    [TABLE]
    [TR]
    [TD="class: gutter"]1
    2
    3
    4
    5
    6
    7
    [/TD]
    [TD="class: code"]Static Message As Long
    Message = X / Screen.TwipsPerPixelX
    Select Case Message
    Case WM_RBUTTONUP:
    Me.PopupMenu Popup
    End Select

    [/TD]
    [/TR]
    [/TABLE]
     
    یک شخص از این تشکر کرد.
  8. کاربر ارشد

    تاریخ عضویت:
    ‏6/9/12
    ارسال ها:
    14,323
    تشکر شده:
    2,698
    امتیاز دستاورد:
    0
    حرفه:
    daneshjo
    پاسخ : یه سری آموزش های فوق العاده جالب برای دوستان عزیز

    گرفتن Screen Resolution
    [TABLE]
    [TR]
    [TD="class: gutter"]1
    2
    3
    4
    [/TD]
    [TD="class: code"]ResWidth = Screen.Width \ Screen.TwipsPerPixelX
    ResHeight = Screen.Height \ Screen.TwipsPerPixelY
    ScreenRes = ResWidth & "x" & ResHeight
    MsgBox (ScreenRes)

    [/TD]
    [/TR]
    [/TABLE]
     
    یک شخص از این تشکر کرد.
  9. کاربر ارشد

    تاریخ عضویت:
    ‏6/9/12
    ارسال ها:
    14,323
    تشکر شده:
    2,698
    امتیاز دستاورد:
    0
    حرفه:
    daneshjo
    پاسخ : یه سری آموزش های فوق العاده جالب برای دوستان عزیز

    لیست فونت های شما و نحوه نمایش آنها :
    یه لیست باکس اضافه کنید :
    [TABLE]
    [TR]
    [TD="class: gutter"]1
    2
    3
    4
    [/TD]
    [TD="class: code"]Dim counter As Integer
    For counter = 0 To Screen.FontCount - 1
    List1.AddItem Screen.Fonts(counter)
    Next

    [/TD]
    [/TR]
    [/TABLE]



    در رویداد On_Click اون Listbox تون این کد رو بزارید :
    [TABLE]
    [TR]
    [TD="class: gutter"]1
    2
    3
    4
    [/TD]
    [TD="class: code"]Static tempheight As Single
    If tempheight = 0 Then tempheight = List1.Height
    List1.Font.Name = List1.List(List1.ListIndex)
    List1.Height = tempheight

    [/TD]
    [/TR]
    [/TABLE]
     
    یک شخص از این تشکر کرد.
  10. کاربر ارشد

    تاریخ عضویت:
    ‏6/9/12
    ارسال ها:
    14,323
    تشکر شده:
    2,698
    امتیاز دستاورد:
    0
    حرفه:
    daneshjo
    پاسخ : یه سری آموزش های فوق العاده جالب برای دوستان عزیز

    تشخیص فشرده شدن کلیک :
    این تابع را بازخوانی کنید :
    user32.dll
    [TABLE]
    [TR]
    [TD="class: gutter"]1
    [/TD]
    [TD="class: code"]Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

    [/TD]
    [/TR]
    [/TABLE]



    حالا تو event یک تایمر اینو بنویسید :
    [TABLE]
    [TR]
    [TD="class: gutter"]1
    2
    3
    4
    5
    6
    7
    [/TD]
    [TD="class: code"]For i = 1 To 255
    results = 0
    results = GetAsyncKeyState(i)
    If results <> 0 Then
    Msgbox(Chr(i))
    End If
    Next

    [/TD]
    [/TR]
    [/TABLE]
     
    یک شخص از این تشکر کرد.