Option Explicit

' Brought to you by:
'   Brad Martinez
'   
Bu forumdaki linkleri ve resimleri görebilmek için en az 25 mesajınız olması gerekir.

'   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