xlDialogBrowse problemi?(Klasöre Gözat penceresi)

[Haluk]

Bu arada bu "Gözat" olayı ile ilgili olarak, biraz daha uzun olmakla birlikte aşağıdaki kodu alternatif olarak önermek isterim.

Kodda belirtildiği gibi, sadece klasörler değil istenirse dosyalar da listelenip seçilebilmektedir ...

Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
        Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
        As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
        Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
        As Long
'
Sub Test()
    MsgBox GetDirectory
End Sub
'
Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer
 
'   Penceredeki kok yol = Masaustu :0&    Belgelerim : &H5  Programlar : &H2
    bInfo.pidlRoot = 0&
'   Dialog penceresinin basligi
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Klasor seciniz ..."
    End If
    
'   Pencerede sadece klasorleri goruntulemek icin
    bInfo.ulFlags = &H1
 
'   Klasör ve dosyaları da beraber görmek istersek
'   bInfo.ulFlags = &H4000
'   Dialog penceresini goster
    x = SHBrowseForFolder(bInfo)
    
'   Geri donen sonucu ayikla
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function

Aslında, dosya seçimi yukarıda Levent dostumun belirttiği kısa yoldan da yapılabilmekte ama Win2000 altında çalıştığı halde, WinXP (Home Ed.) ile çalışmamaktadır. Bu nedenle, eğer dosya da seçilecekse .... birazcık uzun olmasına rağmen bu yöntem daha iyidir.

 

[hsayar]

Set klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)
If Not klasor Is Nothing Then MsgBox klasor.Items.Item.Path

aynı işi yapan alternetif kod aşağıdaki gibi olunca bunların ne kadar güzel olduğu tekrar ortaya çıkıyor

'John Walkenbach's code for getting a directory

Option Explicit
Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
  As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim Path As String
    Dim r As Long, x As Long, pos As Integer
 
'   Root folder = Desktop
    bInfo.pidlRoot = 0&

'   Title in the dialog
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Klasör Seçiniz..."
    Else
        bInfo.lpszTitle = Msg
    End If
    
'   Type of directory to return
    bInfo.ulFlags = &H1

'   Display the dialog
    x = SHBrowseForFolder(bInfo)
    
'   Parse the result
    Path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal Path)
    If r Then
        pos = InStr(Path, Chr$(0))
        GetDirectory = Left(Path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function


Private Sub KlasorSec()
    Msg = "Alt Klasör Açılacak Ana klasörü seçiniz!"
    stPath = GetDirectory(Msg)
    If stPath <> "" Then UserForm1.TextBox1.Value = stPath
End Sub