کادر هاي محاوره حرفه اي

[arash020]

کادر هاي محاوره حرفه اي

سلام

درحال نوشتن برنامه اي هستم که توش نياز دارم کاربر يه آدرس (پوشه دلخواه خودش)رو مشخص و انتخاب کنه
و درصورت نياز پوشه جديدي رو در آدرس دلخواهش ايجاد کنه
مي خوام کادر انتخاب پوشه رو داشته باشم,به همراه دکمه ايجاد پوشه جديد در قسمت پايينش
البته من Ocx نمايش اين کادر رو دارم ولي نمي خوام ازش استفاده کنم
و ضروريه واسم که از dll ها يا توابع خود ويندوز استفاده کنم.
درضمن مي خواستم بدونم ميشه اجزاي جديدتري هم به اين کادر اضافه کرد؟

تشکر

[romina2006]

روش اول :

شما ابتدا از قسمت رفرنسها Microsoft Shell Controls And Automation رو انتخاب كنيد :


Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH As Long = 260

Function BrowseFolder(Optional Caption As String, Optional InitialFolder As String) As String
Dim SH As Shell32.Shell
Dim F As Shell32.Folder
Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)
If Not F Is Nothing Then
BrowseFolder = F.Items.Item.Path
End If
End Function

Private Sub Form_Load()
Call BrowseFolder
End Sub


روش دوم :


Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function

Invalid:
BrowseForFolder = False
End Function

Private Sub Form_Load()
Call BrowseForFolder
End Sub