Parsi Coders
سورس کدهای ویژوال بیسیک - نسخه قابل چاپ

+- Parsi Coders (http://parsicoders.com)
+-- انجمن: Software Development Programming (http://parsicoders.com/forumdisplay.php?fid=37)
+--- انجمن: Visual Basic Programming (http://parsicoders.com/forumdisplay.php?fid=39)
+---- انجمن: Visual Basic 6 (http://parsicoders.com/forumdisplay.php?fid=44)
+---- موضوع: سورس کدهای ویژوال بیسیک (/showthread.php?tid=10)

سورس کدهای ویژوال بیسیک - Amin_Mansouri - 04-15-2011

درود...
در این قسمت سورس کدهای ویژوال بسیک قرار میگیرد.

Source Code Visual Basic 6:

get Serial Hard Disk
به دست اووردن سریال هارد دیسک
کد:
Option Explicit


Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long

Public Function GetDriveSerialNumber(sDrive As String) As Long '/www.parsicoders.com
   Dim lSerialNo    As Long
   Dim lLenSerialNo As Long
  
   GetVolumeInformation sDrive + ":\" & Chr(0), vbNull, vbNull, lSerialNo, lLenSerialNo, vbNull, vbNull, vbNull
   GetDriveSerialNumber = lSerialNo
End Function

Private Sub cmdGetSerialNo_Click()
    MsgBox "Serial Number of Drive C is:" + CStr(GetDriveSerialNumber("c"))
End Sub


RE: سورس کدهای ویژوال بیسیک - Amin_Mansouri - 04-15-2011

Eng:
Get Windows Directories
Persian:
به دست اوردن مسیر پوشه ویندوز
کد:
Option Explicit

'Visual Basic 6
'Www.ParsiCoders.com
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetCurrentDirectory Lib "kernel32" Alias "GetCurrentDirectoryA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Sub Form_Load()
    Dim WindowsDir As String
    Dim SystemDir As String
    Dim TempDir As String
    Dim CurrentDir As String

    CurrentDir = Space(256)
    WindowsDir = Space(256)
    SystemDir = Space(256)
    TempDir = Space(256)
    
    GetWindowsDirectory WindowsDir, Len(WindowsDir)
    txtWindows.Text = WindowsDir
    GetSystemDirectory SystemDir, Len(SystemDir)
    txtSystem.Text = SystemDir
    GetTempPath Len(TempDir), TempDir
    txtTemp.Text = TempDir
    GetCurrentDirectory Len(CurrentDir), CurrentDir
    txtCurrent.Text = CurrentDir
End Sub


RE: سورس کدهای ویژوال بیسیک - Amin_Mansouri - 04-15-2011

سورس های بعدی قابل فهم هستند نیازی به توضیح فارسی نیست.

Wave Player
کد:
Option Explicit


Private Sub Command1_Click()


    Dim FileNumber As Integer
    Dim I As Single
    Dim Min As Single
    Dim Max As Single
    Dim Temp As Integer
    Dim XZoomrate As Single
    Dim YZoomrate As Single
    Dim LastX As Single
    Dim LastY As Single
    On Error Goto ErrorHandler
    ' Enable Cancel error



    With Picture1
        CommonDialog1.CancelError = True
        CommonDialog1........ = "Wave files (*.wav)|*.wav"
        CommonDialog1.ShowOpen
        ' Change the caption of the form

        Me.Caption = CommonDialog1.filename
        I = 44 ' Set I To 44, since the wave sample is begin at Byte 44.
        ' Open file to get the length of the wav

        '    

        'e file.

        FileNumber = FreeFile
        Open CommonDialog1.filename For Random As #FileNumber


        Do
            Get #FileNumber, I, Temp
            I = I + 1
            ' Get the smallest and largest number. T

            '    

            'hey will be use for the adjustment

            ' of the vertical size.

            If Temp < Min Then Min = Temp
            If Temp > Max Then Max = Temp
        Loop Until EOF(FileNumber)


        Close #FileNumber
        ' Adjust values and reset values

        XZoomrate = (.Width / I)
        YZoomrate = (Max - Min) / (.Height / 2)
        .CurrentX = 100
        .CurrentY = .Height / 2
        LastX = 100
        LastY = .Height / 2
        .AutoRedraw = True
        I = 44
        ' Reopen file using a different FileNumb

        '    

        'er

        FileNumber = FileNumber + 1
        .Cls
        Open CommonDialog1.filename For Random As #FileNumber


        Do
            Get #FileNumber, I, Temp
            ' Set CurrentX and CurrentY

            .CurrentX = .CurrentX + XZoomrate
            .CurrentY = (Temp / YZoomrate) + .Height / 2
            ' Plot graph

            Picture1.Line (LastX, LastY)-(.CurrentX, .CurrentY), vbBlack
            ' Reset values

            LastX = .CurrentX
            LastY = .CurrentY
            I = I + 1
            
            If .CurrentX > .Width Then Exit Do
        Loop Until EOF(FileNumber)


        Close #FileNumber
    End With


    
    ErrorHandler:
    ' Do nothing

End Sub




Private Sub Form_Resize()


    On Error Resume Next
    ' Resize control



    With Picture1
        .BackColor = vbWhite
        .ForeColor = vbBlack
        .Move 50, 500, Width - 200, Height - 800
    End With


End Sub


Tray Icon

کد:
Public 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
      
'constants required by Shell_NotifyIcon API call:
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201 'Button down
Public Const WM_LBUTTONUP = &H202 'Button up
Public Const WM_LBUTTONDBLCLK = &H203 'Double-click
Public Const WM_RBUTTONDOWN = &H204 'Button down
Public Const WM_RBUTTONUP = &H205 'Button up
Public Const WM_RBUTTONDBLCLK = &H206 'Double-click


Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
Public nid As NOTIFYICONDATA
      
Sub Initialise(mee As Form)  'Place in form load
    With nid
        .cbSize = Len(nid)
        .hwnd = mee.hwnd
        .uId = vbNull
        .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
        .uCallBackMessage = WM_MOUSEMOVE
        .hIcon = mee.Icon
        '.szTip = " Click Right Mouse Button " & vbNullChar
    End With
    Shell_NotifyIcon NIM_ADD, nid
    mee.Hide
    App.TaskVisible = False

End Sub

Sub PopMenu(mee As Form, x As Single)  'Place in form mouse move
    Dim Msg As Long
    Msg = x / Screen.TwipsPerPixelX

    Select Case Msg
        Case WM_LBUTTONDBLCLK:
          
        Case WM_LBUTTONDOWN:
                
        Case WM_LBUTTONUP:
            mee.PopupMenu mee.mnuPopMenu
        Case WM_RBUTTONDBLCLK:
            
        Case WM_RBUTTONDOWN:
            
        Case WM_RBUTTONUP:
            mee.PopupMenu mee.mnuPopMenu
        
        End Select
End Sub

Sub CloseApp() 'Place in form unload
    Shell_NotifyIcon NIM_DELETE, nid
End Sub

Sub Down(mee As Form)  'Place in form resize
    If mee.WindowState = vbMinimized Then mee.Hide
End Sub
Systary
کد:
'Add the following line to the top of your main form...

Public MyTrayIcon As New <NAME OF ADDED CLASS MODULE (see below)>

'"MyTrayIcon" is the name of the actual trayicon, this icon would
'be classed as an object. The following functions are the events
'of this object.

'To use the tray icon you must add a "Class Module"
'to your project and place the following code into it



Option Explicit

Private 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
  
Private FormHandle As Long
Private mvarbRunningInTray As Boolean
Private SysIcon As NOTIFYICONDATA
Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long

Private Property Let bRunningInTray(ByVal vData As Boolean)
    mvarbRunningInTray = vData
End Property


Property Get bRunningInTray() As Boolean
    bRunningInTray = mvarbRunningInTray
End Property

Public Sub ShowIcon(ByRef sysTrayForm As Form)
    SysIcon.cbSize = Len(SysIcon)
    SysIcon.hwnd = sysTrayForm.hwnd
    SysIcon.uId = vbNull
    SysIcon.uFlags = 7
    SysIcon.ucallbackMessage = 512
    SysIcon.hIcon = sysTrayForm.Icon
    SysIcon.szTip = sysTrayForm.Caption + Chr(0)
    Shell_NotifyIcon 0, SysIcon
    mvarbRunningInTray = True
End Sub

Public Sub RemoveIcon(sysTrayForm As Form)
    SysIcon.cbSize = Len(SysIcon)
    SysIcon.hwnd = sysTrayForm.hwnd
    SysIcon.uId = vbNull
    SysIcon.uFlags = 7
    SysIcon.ucallbackMessage = vbNull
    SysIcon.hIcon = sysTrayForm.Icon
    SysIcon.szTip = Chr(0)
    Shell_NotifyIcon 2, SysIcon
    If sysTrayForm.Visible = False Then sysTrayForm.Show    'Incase user can't see form
    mvarbRunningInTray = False
End Sub

Public Sub ChangeIcon(sysTrayForm As Form, picNewIcon As PictureBox)

If mvarbRunningInTray = True Then   'If running in the tray
    SysIcon.cbSize = Len(SysIcon)
    SysIcon.hwnd = sysTrayForm.hwnd
    'SysIcon.uId = vbNull
    'SysIcon.uFlags = 7
    'SysIcon.ucallbackMessage = 512
    SysIcon.hIcon = picNewIcon.Picture
    'SysIcon.szTip = sysTrayForm.Caption + Chr(0)
    Shell_NotifyIcon 1, SysIcon
End If

End Sub

Public Sub ChangeToolTip(sysTrayForm As Form, strNewTip As String)

If mvarbRunningInTray = True Then   'If running in the tray
    SysIcon.cbSize = Len(SysIcon)
    SysIcon.hwnd = sysTrayForm.hwnd
    SysIcon.szTip = strNewTip & Chr(0)
    Shell_NotifyIcon 1, SysIcon
End If

End Sub
ShutDown
کد:
Private Declare Function 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) As Long


Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long


Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
    
    Private Const EWX_SHUTDOWN = 1

    Dim ret As Integer
    Dim pOld As Boolean
    Dim i
  

Private sub Shutdown()

        ret = SystemParametersInfo(97, False, pOld, 0)
    'SetWindowPos(Form1.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE)

End Sub

Screen Shot
کد:
Declare Function BitBlt Lib "gdi32" _
    (ByVal hDestDC As Integer, ByVal x As Integer, _
    ByVal y As Integer, ByVal nWidth As Integer, _
    ByVal nHeight As Integer, ByVal _
    hSrcDC As Integer, ByVal xSrc As Integer, _
    ByVal ySrc As Integer, ByVal dwRop As _
    Long) As Integer


Declare Function GetDesktopWindow Lib "user32" () As Long


Declare Function GetDC Lib "user32" _
    (ByVal hwnd As Long) As Long
    Public Const SRCCOPY = &HCC0020
    Public Const SRCAND = &H8800C6
    Public Const SRCINVERT = &H660046


Set the Form properties To the following:
AutoRedraw True
BorderStyle 0 - None
WindowState 2 - Maximized


DeskhWnd& = GetDesktopWindow()

DeskDC& = GetDC(DeskhWnd&)
BitBlt Form1.hDC, 0&, 0&, _
Screen.Width, Screen.Height, DeskDC&, _
0&, 0&, SRCCOPY


RE: سورس کدهای ویژوال بیسیک - Amin_Mansouri - 04-16-2011

randomcodenum
کد:
Private Sub Command1_Click()

    Dim A As String
    Dim B As String
    Dim C As String
    Dim D As String
    Dim E As String
    Dim F As String
    Dim G As String
    Dim H As String
    Dim I As String
    Dim J As String

    A = Random
    B = Random
    C = Random
    D = Random
    E = Random
    F = Random
    G = Random
    H = Random
    I = Random
    J = Random

    Text1 = A + B + C + D + E + F + G + H + I + J

End Sub

Function RandomNum() As Integer

    RandomNum = Int((9 - 1 + 1) * Rnd + 1)

End Function

Function RandomChar() As String

    Dim Char As Integer
    Char = Int((26 - 1 + 1) * Rnd + 1)
    If Char = 1 Then RandomChar = "A": Exit Function
    If Char = 2 Then RandomChar = "B": Exit Function
    If Char = 3 Then RandomChar = "C": Exit Function
    If Char = 4 Then RandomChar = "D": Exit Function
    If Char = 5 Then RandomChar = "E": Exit Function
    If Char = 6 Then RandomChar = "F": Exit Function
    If Char = 7 Then RandomChar = "G": Exit Function
    If Char = 8 Then RandomChar = "H": Exit Function
    If Char = 9 Then RandomChar = "I": Exit Function
    If Char = 10 Then RandomChar = "J": Exit Function
    If Char = 11 Then RandomChar = "K": Exit Function
    If Char = 12 Then RandomChar = "L": Exit Function
    If Char = 13 Then RandomChar = "M": Exit Function
    If Char = 14 Then RandomChar = "N": Exit Function
    If Char = 15 Then RandomChar = "O": Exit Function
    If Char = 16 Then RandomChar = "P": Exit Function
    If Char = 17 Then RandomChar = "Q": Exit Function
    If Char = 18 Then RandomChar = "R": Exit Function
    If Char = 19 Then RandomChar = "S": Exit Function
    If Char = 20 Then RandomChar = "T": Exit Function
    If Char = 21 Then RandomChar = "U": Exit Function
    If Char = 22 Then RandomChar = "V": Exit Function
    If Char = 23 Then RandomChar = "W": Exit Function
    If Char = 24 Then RandomChar = "X": Exit Function
    If Char = 25 Then RandomChar = "Y": Exit Function
    If Char = 26 Then RandomChar = "Z": Exit Function

End Function

Function Random() As Variant

    Dim Randm As Integer
    Randm = Int((3 - 1 + 1) * Rnd + 1)
    
    If Randm = 1 Then
        Random = RandomNum
    Else
        Random = RandomChar
    End If

End Function
Puts Pics into Menus
کد:
Private 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 Long
    cch As Long
End Type
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bypos As Long, lpcMenuItemInfo As MENUITEMINFO) As Long
Private Const MF_BITMAP = &H4&
Private Const MFT_BITMAP = MF_BITMAP
Private Const MIIM_TYPE = &H10

Private Sub Form_Load()
    ' Set the menu bitmaps.
    SetMenuBitmap Me, Array(0, 0), imgExit.Picture            'Picture Areas in menu
    SetMenuBitmap Me, Array(1, 0), imgDelete.Picture
    SetMenuBitmap Me, Array(1, 1, 0), imgStop.Picture
    SetMenuBitmap Me, Array(1, 1, 1), imgYield.Picture
    SetMenuBitmap Me, Array(1, 1, 2), imgCaution.Picture
End Sub
' Put a bitmap in a menu item.
Public Sub SetMenuBitmap(ByVal frm As Form, ByVal item_numbers As Variant, ByVal pic As Picture)
Dim menu_handle As Long
Dim i As Integer
Dim menu_info As MENUITEMINFO

    ' Get the menu handle.
   menu_handle = GetMenu(frm.hwnd)
    For i = LBound(item_numbers) To UBound(item_numbers) - 1
        menu_handle = GetSubMenu(menu_handle, item_numbers(i))
    Next i
    With menu_info
        .cbSize = Len(menu_info)
        .fMask = MIIM_TYPE
        .fType = MFT_BITMAP
        .dwTypeData = pic
    End With
    SetMenuItemInfo menu_handle, item_numbers(UBound(item_numbers)), True, menu_info
End Sub
playsound
کد:
Public Declare Function sndPlaySound Lib "winmm" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

Public Sub PlaySound(strFileName As String)
    sndPlaySound strFileName, 1
End Sub
Open File
کد:
Open Dialogs.fileName For Input As #1
    
    Do While Not EOF(1)
        Line Input #1, Temp
        text1.Text = text1.Text + vbCrLf & Temp
        DoEvents
    Loop

Close #1
no spaces
کد:
' add a text box and place this in it. Rename text1 to the name
' of the text box.

    Dim Length As String
    
    For L = 1 To text1.MaxLength
            
        Length = Length + " "
        If text1 = "" Or text1 = Length Then
            MsgBox "You can't have spaces in this textbox!"
            'Exit Sub
    End If
            
    Next L
move a form without title bar
کد:
Private OldX As Integer
Private OldY As Integer
Private DragMode As Boolean
Dim MoveMe As Boolean

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    MoveMe = True
    OldX = X
    OldY = Y

End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

    If MoveMe = True Then
        Me.Left = Me.Left + (X - OldX)
        Me.Top = Me.Top + (Y - OldY)
    End If

End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

    Me.Left = Me.Left + (X - OldX)
    Me.Top = Me.Top + (Y - OldY)
    MoveMe = False

End Sub
Midi Play
کد:
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

Private Sub Form_Load()
  result = mciSendString("open c:\windows\canyon.mid type sequencer alias canyon", 0&, 0, 0)
  result = mciSendString("play canyon", 0&, 0, 0)
End Sub

Private Sub Form_Unload()
   result = mciSendString("close all", 0&, 0, 0)
End Sub


RE: سورس کدهای ویژوال بیسیک - Ghoghnus - 08-22-2011

(04-15-2011، 11:07 PM)پارسا نوشته: Eng:
Get Windows Directories
Persian:
به دست اوردن مسیر پوشه ویندوز
کد:
Option Explicit

'Visual Basic 6
'Www.ParsiCoders.com
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetCurrentDirectory Lib "kernel32" Alias "GetCurrentDirectoryA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Sub Form_Load()
    Dim WindowsDir As String
    Dim SystemDir As String
    Dim TempDir As String
    Dim CurrentDir As String

    CurrentDir = Space(256)
    WindowsDir = Space(256)
    SystemDir = Space(256)
    TempDir = Space(256)
    
    GetWindowsDirectory WindowsDir, Len(WindowsDir)
    txtWindows.Text = WindowsDir
    GetSystemDirectory SystemDir, Len(SystemDir)
    txtSystem.Text = SystemDir
    GetTempPath Len(TempDir), TempDir
    txtTemp.Text = TempDir
    GetCurrentDirectory Len(CurrentDir), CurrentDir
    txtCurrent.Text = CurrentDir
End Sub
روش سادتر برای بدست اوردن مسیر ها های رزرو شده (مثلا ویندوز)
کد:
Environ  ("windir")


RE: سورس کدهای ویژوال بیسیک - Amin_Mansouri - 10-03-2011

تایپ کردن فقط اعداد در تکست باکس :

کد:
Private Sub txtNumber_KeyPress(KeyAscii As Integer)
If KeyAscii >= 48 And KeyAscii <= 57 Then
Else
KeyAscii = 0
End If
End Sub


RE: سورس کدهای ویژوال بیسیک - kalam - 05-30-2014

پخش فایل تصویری با پسوند avi یا wmv

 

RE: سورس کدهای ویژوال بیسیک - alikorg - 05-07-2017

سلام
لطفا سورس کد یونیک متن فارسی توسط دستورات at command را لطف کنید
من با این دستور میتوانم توسط mscom پیام انگلیسی بدم .اما فارسی نمیتونم.
متشکرم.

RE: سورس کدهای ویژوال بیسیک - minarad69 - 05-15-2017

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