Klasöre Gözat Diyaloğu

Public Enum Root
    MasaUstu = 0
    ProgramlarDizini = 2
    DenetimMasasi = 3
    Yazicilar = 4
    Belgelerim = 5
    SikKullanilanlar = 6
    BaslangicProgramDizini = 7
    SonKullanilanOgelerDizini = 8
    SendToDizini = 9
    CopKutusu = 10
    BaslatMenuDizini = 11
    MasaUstuDizini = 16
    Bilgisayarim = 17
    NetworkKullanicilari = 18
    NetworkKisayolDizini = 19
    Fonts = 20
    TemplatesDizini = 21
End Enum

Public Enum Options
    ReturnAll = 0
    ReturnOnlyFileSystemDirs = 1
    DontIncludeNetworkDirs = 2
    IncludeStatusText = 4
    ReturnOnlySystemAncestors = 8
    EditBox = 16
    Validate = 32
    NewDialogStyle = 64
    BrowseInludeUrls = 128
    DontIncludeNewFolderButton = 512
    DontIncludeTranslateTargets = 1024
    BrowseForComputer = 4096
    BrowseForPrinter = 8192
    IncludeFiles = 16384
    Shareable = -32768
    FileJunction = 65536 ' Win7 ve sonrası. Zip dosyaları da klasör gibi ekle
End Enum

#If VBA7 And Win64 Then
    Private Type BROWSEINFO
       hwndOwner      As LongLong ' Çoğu zaman 0 veya Form Handle No
       pidlRoot       As LongLong ' Kök dizin(Root)
       pszDisplayName As String   ' Seçilen elemanın adı (Path değil)
       pszTitle       As String   ' Pencere mesajı
       ulFlags        As LongLong ' Seçenekler (Options)
       lpfn           As LongLong ' Initial Klasörü atama ve seçimi ekrana yazmak için CallBack
       lParam         As LongLong ' Açılışta ve seçimde seçili olacak klasör
       iImage         As LongLong '
    End Type
#Else
    Private Type BROWSEINFO
       hwndOwner      As Long   ' Çoğu zaman 0 veya Form Handle No
       pidlRoot       As Long   ' Kök dizin(Root)
       pszDisplayName As String ' Seçilen elemanın adı (Path değil)
       pszTitle       As String ' Pencere mesajı
       ulFlags        As Long   ' Seçenekler (Options)
       lpfn           As Long   ' Initial Klasörü atama ve seçimi ekrana yazmak için CallBack
       lParam         As Long   ' Açılışta seçili olacak klasör
       iImage         As Long   '
    End Type
#End If

#If VBA7 And Win64 Then
    ' Pencere çağıran API
    Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
       Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongLong
    
    ' Seçimin sonucu için
    Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
       Alias "SHGetPathFromIDListA" (ByVal pidl As LongLong, ByVal pszPath As String) As LongLong
    
    ' Herhangi bir dizini Root yapmak için path in sayısal karşılığı
    Private Declare PtrSafe Function SHParseDisplayName Lib "shell32.dll" _
      (ByVal pszName As LongLong, ByVal pbc As LongLong, ByRef ppidl As LongLong, _
       ByVal sfgaoIn As LongLong, ByRef psfgaoOut As LongLong) As LongLong
    
    ' Hem açılışta seçili dizin, hem de gezinirken tam yolu ekrana yazma için gerekli
    Private Declare PtrSafe Function SendMessage Lib "user32" _
       Alias "SendMessageA" (ByVal hwnd As LongLong, ByVal wMsg As LongLong, _
       ByVal wParam As LongLong, ByVal lParam As Any) As LongLong
    
    ' Diyalog pencere başlığına yazı yazmak istersek
    Private Declare PtrSafe Function SetWindowText Lib "user32" _
       Alias "SetWindowTextA" (ByVal hwnd As LongLong, ByVal lpString As String) As LongLong
    
    ' Bellekte sabit yer aç
    Private Declare PtrSafe Function LocalAlloc Lib "kernel32" _
      (ByVal uFlags As LongLong, ByVal uBytes As LongLong) As LongLong
    
    ' Belleği kopyala
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" _
       Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As LongLong)

    ' Belleği serbest bırak
    Private Declare PtrSafe Function LocalFree Lib "kernel32" _
      (ByVal hMem As LongLong) As LongLong
   
    ' Diayalogda sonraki çağırımda önceki çağırım ayarını sil
    Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As LongLong)
#Else
    ' Pencere çağıran API
    Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
       Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
    
    ' Seçimin sonucu için
    Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
       Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
    
    ' Herhangi bir dizini Root yapmak için path in sayısal karşılığı
    Private Declare Function SHParseDisplayName Lib "shell32.dll" _
      (ByVal pszName As Long, ByVal pbc As Long, ByRef ppidl As Long, _
       ByVal sfgaoIn As Long, ByRef psfgaoOut As Long) As Long
    
    ' Diyalog pencere başlığına yazı yazmak istersek
    Private Declare Function SetWindowText Lib "user32" _
       Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    
    ' Hem açılışta seçili dizin, hem de gezinirken tam yolu ekrana yazma için gerekli
    Private Declare Function SendMessage Lib "user32" _
       Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
       ByVal wParam As Long, ByVal lParam As Any) As Long
    
    ' Bellekte sabit yer aç
    Private Declare Function LocalAlloc Lib "kernel32" _
      (ByVal uFlags As Long, ByVal uBytes As Long) As Long
    
    ' Belleği kopyala
    Private Declare Sub CopyMemory Lib "kernel32" _
       Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)

    ' Belleği serbest bırak
    Private Declare Function LocalFree Lib "kernel32" _
      (ByVal hMem As Long) As Long
   
    ' Diayalogda sonraki çağırımda önceki çağırım ayarını sil
    Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
#End If

Private mCaption As String

Public Function BrowseFolder(Optional vCaption As String = "", Optional Msg As String = "", _
                             Optional vOptions As Options = ReturnAll, Optional LongRoot As Root = MasaUstu, _
                             Optional StrRoot As String = "", Optional DefaultDir As String = "") As String
    
    #If VBA7 And Win64 Then
        Dim pidl As LongLong, pidl2 As LongLong, lpDefaultDir As LongLong
    #Else
        Dim pidl As Long, pidl2 As Long, lpDefaultDir As Long
    #End If
    
    mCaption = vCaption ' Pencere başlığında görünecek yazı
    
    Dim bi As BROWSEINFO, strRet As String, spath As String * 260
    
    With bi
        .hwndOwner = 0
        .pidlRoot = LongRoot
    If Trim$(StrRoot) <> "" Then ' İsteğe bağlı Root için başla
        Call SHParseDisplayName(StrPtr(StrRoot), 0, pidl2, 0, 0)
        .pidlRoot = pidl2
    End If
        .pszTitle = Msg ' İleti
        .pszDisplayName = Space$(260) ' Seçimin yalnız başlığı için String Buffer
        .ulFlags = vOptions
        .lpfn = Dummy(AddressOf BrowseCallback) ' Hem açılınca, hem seçim anında seçimi görme için
        
        lpDefaultDir = LocalAlloc(64, Len(DefaultDir) + 1)
        CopyMemory ByVal lpDefaultDir, ByVal DefaultDir, Len(DefaultDir) + 1
        
        .lParam = lpDefaultDir
    End With
    
    pidl = SHBrowseForFolder(bi) ' Diyaloğu aç
 
    If pidl = 0 Then GoTo Clean ' İptal butonuna basıldıysa
    
    If SHGetPathFromIDList(pidl, spath) <> 0 Then ' Path'i spath değişkenine ata
        strRet = TrimNull(spath)
    End If
    
    ' Yazıcı ve Bilgisayar isimleri Path olmadığı için aşağıdaki satır ile alıyoruz. İstersek,
    ' seçime bağlı olarak CallBack içinde Path kontrolu ile Tamam butonunu aktif/pasif yapabiliriz.
    ' Ancak, bu fonk.sonucunun bir Path olup olmadığı kontrolünü çağırdığınız yerde yapmanız uygun olur.
    If strRet = "" Then strRet = TrimNull(bi.pszDisplayName)
    
    BrowseFolder = strRet
    
Clean:
    Call CoTaskMemFree(pidl)
    Call LocalFree(lpDefaultDir)
End Function

#If VBA7 And Win64 Then
    Private Function BrowseCallback(ByVal hwnd As LongLong, ByVal uMsg As LongLong, ByVal lParam As LongLong, _
                                   ByVal lpData As LongLong) As LongLong
#Else
    Private Function BrowseCallback(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lParam As Long, _
                                   ByVal lpData As Long) As Long
#End If

        '*** BrowseCallback fonksiyonu bir .bas modul içinde olmak zorundadır. ***'
        
        On Error Resume Next ' Excel çökmesin
        
        Dim sBuffer As String * 260
                
        #If VBA7 And Win64 Then
            Dim btnOK As LongLong
        #Else
            Dim btnOK As Long
        #End If
        
        Select Case uMsg
            Case 1 ' Initialize modunda belirtilen dizin seçili gelecektir (DefaultDir)
                If lpData <> 0 Then
                    If mCaption <> "" Then _
                    Call SetWindowText(hwnd, mCaption) ' Diyalog başlığına yaz
                    Call SendMessage(hwnd, 1126, 1, ByVal lpData) ' Diyalog Status Text e yaz
                End If
            Case 2 ' Selection modunda dizinler üzerinde gezinirken seçimi göster
                If SHGetPathFromIDList(lParam, sBuffer) <> 0 Then ' Seçim, bir Path ise
                    'btnOK = 1
                    'Call SendMessage(hwnd, 1125, 0, btnOK) ' Tamam aktif
                    Call SendMessage(hwnd, 1124, 0, sBuffer)
                    'Call SetWindowText(hwnd, TrimNull(sBuffer)) ' Seçimi pencere başlığına yazdırmak istersek
                Else
                    'btnOK = 0
                    'Call SendMessage(hwnd, 1125, 0, btnOK) ' Tamam pasif
                End If
        End Select
    End Function

#If VBA7 And Win64 Then
    Private Function Dummy(lpProcName As LongLong) As LongLong
#Else
    Private Function Dummy(lpProcName As Long) As Long
#End If
    ' BrowseCallback'in adresini AddressOf ile alabilmek için gerekli kıytırık fonksiyon.
        Dummy = lpProcName
    End Function

Private Function TrimNull(metin As String) As String
' API metnini VB metnine çevirme
    TrimNull = Left$(Trim$(metin), Len(Trim$(metin)) - 1)
End Function

Yazar: mmustafaaslan

2004 yilindan itibaren ozel bir sirketin finans departmaninda calismaktadir. Kendini excel, visual basic kullaniminda gelistirmis olan yazarimiz; Meslegi geregi SAP konusunda ileri derecede bilgilidir.

“Klasöre Gözat Diyaloğu” için 1 yorum

  1. Merhaba. Ben bunu kullanmayı beceremedim. Kusuruma bakmazsanız bir örnek dosya koymanızı rica edebilirmiyim. İyi günler dilerim.

Bir Cevap Yazın

E-posta hesabınız yayımlanmayacak. Gerekli alanlar * ile işaretlenmişlerdir


4 + 1 =