Dosya ve Klasör Arama

Option Explicit

' Brought to you by:
' Brad Martinez
' btmtz@aol.com
' http://members.aol.com/btmtz/vb

' Currently selected option button
Dim m_wCurOptIdx As Integer


Private Sub Form_Load()

Dim wIdx As Integer, nFolder As Long
Dim sPath As String * MAX_PATH ' 260
Dim IDL As ITEMIDLIST

Move (Screen.Width - Width) * 0.5, (Screen.Height - Height) * 0.5
pic16Icon.AutoRedraw = True ' this is a demo...
pic32Icon.AutoRedraw = True

' Loads the labels with the respective
' system folder's path (if found)
For wIdx = 1 To 17
nFolder = GetFolderValue(wIdx)

' Fill the item id list with the pointer of each folder item, rtns 0 on success
If SHGetSpecialFolderLocation(Me.hWnd, nFolder, IDL) = NOERROR Then

' Get the path from the item id list pointer, rtns True on success
If SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath) Then

' Display the path in the respective label
labFolderPath(wIdx) = Left$(sPath, InStr(sPath, vbNullChar) - 1)

End If

Else
' The folder item doesn't exist, disable it's checkbox
optFolder(wIdx).Enabled = False

End If
Next

End Sub

Private Function GetFolderValue(wIdx As Integer) As Long
' Returns the value of the system folder constant specified by wIdx
' See BrowsDlg.bas for the system folder nFolder values

' The Desktop
If wIdx < 2 Then
GetFolderValue = 0

' Programs Folder --> Start Menu Folder
ElseIf wIdx < 12 Then
GetFolderValue = wIdx

' Desktop Folder --> ShellNew Folder
Else ' wIdx >= 12
GetFolderValue = wIdx + 4
End If

End Function

Private Sub optFolder_Click(Index As Integer)
' Save the current option button index
m_wCurOptIdx = Index
End Sub

Private Function GetReturnType() As Long
Dim dwRtn As Long
If chkRtnType(0) Then dwRtn = dwRtn Or BIF_RETURNONLYFSDIRS
If chkRtnType(1) Then dwRtn = dwRtn Or BIF_DONTGOBELOWDOMAIN
' If chkRtnType(2) Then dwRtn = dwRtn Or BIF_STATUSTEXT ' callback only
If chkRtnType(3) Then dwRtn = dwRtn Or BIF_RETURNFSANCESTORS
If chkRtnType(4) Then dwRtn = dwRtn Or BIF_BROWSEFORCOMPUTER
If chkRtnType(5) Then dwRtn = dwRtn Or BIF_BROWSEFORPRINTER
GetReturnType = dwRtn
End Function

Private Sub cmdBrowse_Click()

Dim BI As BROWSEINFO
Dim nFolder As Long
Dim IDL As ITEMIDLIST
Dim pIdl As Long
Dim sPath As String
Dim SHFI As SHFILEINFO

With BI
' The dialog's owner window...
.hOwner = Me.hWnd

' Set the Browse dialog root folder
nFolder = GetFolderValue(m_wCurOptIdx)

' Fill the item id list with the pointer of the selected folder item, rtns 0 on success
' ==================================================
' If this function fails because the selected folder doesn't exist,
' .pidlRoot will be uninitialized & will equal 0 (CSIDL_DESKTOP)
' and the root will be the Desktop.
' DO NOT specify the CSIDL_ constants for .pidlRoot !!!!
' The SHBrowseForFolder() call below will generate a fatal exception
' (GPF) if the folder indicated by the CSIDL_ constant does not exist!!
' ==================================================
If SHGetSpecialFolderLocation(ByVal Me.hWnd, ByVal nFolder, IDL) = NOERROR Then
.pidlRoot = IDL.mkid.cb
End If

' Initialize the buffer that rtns the display name of the selected folder
.pszDisplayName = String$(MAX_PATH, 0)

' Set the dialog's banner text
.lpszTitle = "Browsing is limited to: " & optFolder(m_wCurOptIdx).Caption

' Set the type of folders to display & return
' -play with these option constants to see what can be returned
.ulFlags = GetReturnType()

End With

' Clear previous return vals before the
' dialog is shown (it might be cancelled)
txtPath = ""
txtDisplayName = ""
pic16Icon.Picture = LoadPicture() ' clears prev icon
pic32Icon.Picture = LoadPicture()

' Show the Browse dialog
pIdl = SHBrowseForFolder(BI)

' If the dialog was cancelled...
If pIdl = 0 Then Exit Sub

' Fill sPath w/ the selected path from the id list
' (will rtn False if the id list can't be converted)
sPath = String$(MAX_PATH, 0)
SHGetPathFromIDList ByVal pIdl, ByVal sPath

' Display the path and the name of the selected folder
txtPath = Left(sPath, InStr(sPath, vbNullChar) - 1)
txtDisplayName = Left$(BI.pszDisplayName, _
InStr(BI.pszDisplayName, vbNullChar) - 1)

' Get the 16x16 icon info from the id list using the pidl
SHGetFileInfo ByVal pIdl, 0&, SHFI, Len(SHFI), _
SHGFI_PIDL Or SHGFI_ICON Or SHGFI_SMALLICON
' The 16x16 icon handle rtnd in SHFI.hIcon is stretched to 32x32.
' DrawIconEx() will shrink (or stretch) the icon per it's cxWidth & cyWidth params
DrawIconEx pic16Icon.hdc, 0, 0, SHFI.hIcon, 16, 16, 0, 0, DI_NORMAL
pic16Icon.Refresh

' Get the 32x32 icon info from the id list
SHGetFileInfo ByVal pIdl, 0&, SHFI, Len(SHFI), _
SHGFI_PIDL Or SHGFI_ICON
' SHFI.hIcon is OK here so DrawIcon() can be used
DrawIcon pic32Icon.hdc, 0, 0, SHFI.hIcon
pic32Icon.Refresh

' Frees the memory SHBrowseForFolder()
' allocated for the pointer to the item id list
CoTaskMemFree pIdl

End Sub

Private Sub cmdInfo_Click()
MsgBox "If a root folder Option Button has no correspnoding folder location " & _
"displayed, then no Registry entry exists for it under:" & vbCrLf & vbCrLf & _
"HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders" & _
vbCrLf & vbCrLf & "As well, if a root folder Option Button is disabled, the folder " & _
"does not exist in your file system and cannot be dispalyed as the root in the Browse dialog."
End Sub

Private Sub cmdQuit_Click()
Unload Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set Form1 = Nothing
End
End Sub

Yorum Yapabilmek İçin Üye Girişi Yapmanız Gerekmektedir.

dosya ve klasör arama