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

سورس های کاربردی و پیشرفته

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

  1. کاربر ارشد

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

    ساخت لینک
    کد PHP:

    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.persiancoder.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
     
  2. کاربر ارشد

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

    دادن تم Xp به برنامه
    واسه اين كار Notepad رو باز كنين و كد زير رو توش كپي كنيد
    کد PHP:
    <?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 در كد بالا نام برنامه تون رو بزارين
    فايل را با نام x.exe.MANIFEST ذخيره كنين x همون نام برنامه است
    حالا توي VB برين و توي فرم يه ProgressBar بزارين
    از برنامه يه نسخه اجرايي بگيرين
     
  3. کاربر ارشد

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

    انتقال فایل

    Private Sub Command1_Click()
    Name "c:\a.bat" As "D:\h.bat"
    End Sub
     
  4. کاربر ارشد

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

    کادر باز کردن پوشه (Folder Browse )

    در ماوژول :
    کد PHP:
    Public Const BIF_RETURNONLYFSDIRS = 1
    Public Const BIF_DONTGOBELOWDOMAIN = 2
    Public Const MAX_PATH = 260
    Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
    Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
    Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
    '***
    Public Type BrowseInfo
    hWndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
    End Type


    در فرم :
    کد PHP:
    Private Sub Command1_Click()
    Dim lpIDList As Long
    Dim sBuffer
    As String
    Dim szTitle
    As String
    Dim BrowseInf
    As BrowseInfo
    szTitle
    = "ÌÓÊÌæí Ú˜Ó"
    With BrowseInf
    .hWndOwner = Me.hWnd
    .lpszTitle = lstrcat(szTitle, "")
    .
    ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
    End With
    lpIDList
    = SHBrowseForFolder(BrowseInf)
    If (
    lpIDList) Then
    sBuffer
    = Space(MAX_PATH)
    SHGetPathFromIDList lpIDList, sBuffer
    'sBuffer value is the directory that the user choose from the dialog.
    sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
    Text1.Text = sBuffer

    End If
    End Sub
     
  5. کاربر ارشد

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

    بازیابی سطر معینی از یک فایل

    کد PHP:
    Public Function readLine(ByRef strFilePath As String, ByRef nLine _
    As Integer) As String

    Dim NextLine
    As String
    Dim n
    As Integer
    FileNum
    = FreeFile
    Open strFilePath
    For Input As FileNum
    Do Until EOF(FileNum)
    Line Input #FileNum, NextLine
    n = n + 1
    If n = nLine Then readLine = NextLine
    Loop
    Close
    End
    Function
    Private
    Sub Command1_Click()

    Text1.Text = readLine("d:\a.bat", 3)
    End Sub
     
  6. کاربر ارشد

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

    پنجره ی غیر قابل حرکت
    کد PHP:
    Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, _
    ByVal bRevert
    As Long) As Long
    Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, _
    ByVal nPosition
    As Long, ByVal wFlags As Long) As Long
    Private Const SC_MOVE = &HF010&
    Private Const
    MF_BYCOMMAND = &H0&

    Private
    Sub Command1_Click()
    lhSysMenu = GetSystemMenu(Me.hwnd, False)
    lRetVal = RemoveMenu(lhSysMenu, SC_MOVE, MF_BYCOMMAND)
    End Sub
     
  7. کاربر ارشد

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

    جستجو با کمک توابع API

    کد PHP:
    'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
    '
    Add 1 Command Button, 4 Text Boxes and 1 List Box to your Form.
    'At Run-Time, Enter the path that you want to start to search from it to Text1,
    '
    Enter the file pattern to Text2 (like *.* or *.exe), and press the button.
    'List1 will be filled with all the matching files, Text3 will display the number of files found,
    '
    And Text4 will display the total size of the files found.
    'Insert this code to the module :

    Private Declare Function FindFirstFile Lib "kernel32" Alias _
    "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData _
    As WIN32_FIND_DATA) As Long
    Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" _
    (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
    Private Declare Function GetFileAttributes Lib "kernel32" Alias _
    "GetFileAttributesA" (ByVal lpFileName As String) As Long
    Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) _
    As Long

    Private Const MAX_PATH = 260
    Private Const MAXDWORD = &HFFFF
    Private Const INVALID_HANDLE_VALUE = -1
    Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
    Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
    Private Const FILE_ATTRIBUTE_HIDDEN = &H2
    Private Const FILE_ATTRIBUTE_NORMAL = &H80
    Private Const FILE_ATTRIBUTE_READONLY = &H1
    Private Const FILE_ATTRIBUTE_SYSTEM = &H4
    Private Const FILE_ATTRIBUTE_TEMPORARY = &H100

    Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
    End Type

    Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
    End Type

    Private Function StripNulls(OriginalStr As String) As String
    If (InStr(OriginalStr, Chr(0)) > 0) Then
    OriginalStr = Left(OriginalStr, _
    InStr(OriginalStr, Chr(0)) - 1)
    End If
    StripNulls = OriginalStr
    End Function


    '
    Insert the following code to your form:

    Private Function
    FindFilesAPI(path As String, SearchStr As String, _
    FileCount
    As Integer, DirCount As Integer)
    Dim FileName As String
    Dim DirName
    As String
    Dim dirNames
    () As String
    Dim nDir
    As Integer
    Dim i
    As Integer
    Dim hSearch
    As Long
    Dim WFD
    As WIN32_FIND_DATA
    Dim Cont
    As Integer
    If Right(path, 1) <> "\" Then path = path & "\"
    nDir = 0
    ReDim dirNames(nDir)
    Cont = True
    hSearch = FindFirstFile(path & "
    *", WFD)
    If hSearch <> INVALID_HANDLE_VALUE Then
    Do While Cont
    DirName = StripNulls(WFD.cFileName)
    If (DirName <> "
    .") And (DirName <> "..") Then
    If GetFileAttributes(path & DirName) And _
    FILE_ATTRIBUTE_DIRECTORY Then
    dirNames(nDir) = DirName
    DirCount = DirCount + 1
    nDir = nDir + 1
    ReDim Preserve dirNames(nDir)
    End If
    End If
    Cont = FindNextFile(hSearch, WFD)
    Loop
    Cont = FindClose(hSearch)
    End If
    hSearch = FindFirstFile(path & SearchStr, WFD)
    Cont = True
    If hSearch <> INVALID_HANDLE_VALUE Then
    While Cont
    FileName = StripNulls(WFD.cFileName)
    If (FileName <> "
    .") And (FileName <> "..") Then
    FindFilesAPI = FindFilesAPI + (WFD.nFileSizeHigh * _
    MAXDWORD) + WFD.nFileSizeLow
    FileCount = FileCount + 1
    List1.AddItem path & FileName
    End If
    Cont = FindNextFile(hSearch, WFD)
    Wend
    Cont = FindClose(hSearch)
    End If
    If nDir > 0 Then
    For i = 0 To nDir - 1
    FindFilesAPI = FindFilesAPI + FindFilesAPI(path & dirNames(i) _
    & "
    \", SearchStr, FileCount, DirCount)
    Next i
    End If
    End Function

    Private Sub Command1_Click()
    Dim SearchPath As String, FindStr As String
    Dim FileSize As Long
    Dim NumFiles As Integer, NumDirs As Integer
    Screen.MousePointer = vbHourglass
    List1.Clear
    SearchPath = Text1.Text
    FindStr = Text2.Text
    FileSize = FindFilesAPI(SearchPath, FindStr, NumFiles, NumDirs)
    Text3.Text = NumFiles & "
    Files found in " & NumDirs + 1 & _
    "
    Directories"
    Text4.Text = "
    Size of files found under " & SearchPath & " = " & _
    Format(FileSize, "
    #,###,###,##0") & " Bytes"
    Screen.MousePointer = vbDefault
    End Sub
     
  8. کاربر ارشد

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

    ایجاد شاخه
    کد PHP:
    Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long
    Private Sub Form_Load()
    'KPD-Team 2000
    '
    URL: http://www.allapi.net/
    'E-Mail: KPDTeam[MENTION=54160]alla[/MENTION]pi.net
    '
    create the directory 'c:\test\dir\hello\something\apiguide\'
    SHCreateDirectoryEx Me.hwnd, "c:\test\dir\hello\something\apiguide\", ByVal 0&
    End Sub
     
  9. کاربر ارشد

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

    پخش فايل صوتي
    راحت ترين روش
    كافيه يه Textbox بزارين و دو command Button به صورتي كه دومي كپي اولي باشه و آرايه درست بشه

    اين كد ها رو تو جنرال فرمتون كپي كنين
    کد PHP:

    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 تا واستون اجرا كنه
     
  10. کاربر ارشد

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

    تغییر کلید میانبر یک منو در زمان اجرا

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

    1- پروژه جدیدی را در ویژوال بیسیک آغاز کنید . بطور پیش فرض Form1 ایجاد می شود.
    2- کد زیر را به قسمت معرفیهای عمومی فرم اضافه کنید :


    Option Explicit

    Dim ShortCut as String * 1


    3- از منوی Tools روی گزینه Menu Editor کلیک کنید تا یک منوی ساده ایجاد شود . در محل Caoption کلمه : File& و در محل مربوط به نام mnuFile را وارد و روی Ok کلیک کنید تا یک ساختار منویی ایجاد شود . سپس به حالت طراحی ویژوال بیسیک برگردید.

    4- کد زیر را در رویداد Load مربوط به Form1 وارد کنید.


    Private Sub Form_Load()

    Command1.Caption = "Change ShortCut"

    KeyPreview = True

    End Sub


    5- کد زیر را هم در رویداد KeyDown فرم اضافه نمایید :


    Private Sub Form_KeyDown (KeyCode As Integer , Shift As Integer)

    If Shift And 2 <> 2 Then Exit Sub

    If Keycode = Asc(ShortCut) Then

    mnuFile_Click

    End If

    End Sub


    6- کد زیر را در رویداد Click منوی mnuFile وارد کنید :


    Private Sub mnuFile_Click()

    MsgBox "Menu Was Selected"

    End Sub


    7- کنترلی از نوع Command Button به فرم اضافه کنید . Command1 بطور پیش فرض ایجاد می شود . خصوصیت Caption آنرا به Change Item تنظیم نمایید.

    8- کد زیر را به رویداد Click این دکمه اضافه کنید :


    Private Sub Command1_Click()

    ShortCut = "E"

    mnuFile.Caption = "Fill" & "&" & LCase$(ShortCut)

    End Sub


    با فشاردادن کلید F5 برنامه را اجرا کنید . به منوی بالای فرم توجه کنید . گزینه منو File"" می باشد که زیر حرف F آن خط کشیده شده است . حرف F ، کلید دستیابی به منوی مزبور می باشد . روی دکمه کلیک کنید . گزینه منوی به File تغییر داده می شود منتهی این بار زیر حرف e آن خط کشیده شده است . کلید ترکیبی Ctrl + E را روی ضفحه فشار دهید . یک کادر پیغام باز می شود که مضمون آن به این صورت است : Menu Was Selected