用Shell对象打开目录选择的问题

Question

最好贴出来大家看吧。
email: [email protected]

Answer 1

Private Const MAX_PATH = 260
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
        "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPrivate Declare Function SHGetSpecialFolderLocation Lib _
        "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder _
        As Long, pIdl As ITEMIDLIST) As LongPrivate Declare Function SHGetFileInfo Lib "Shell32" Alias _
        "SHGetFileInfoA" (ByVal pszPath As Any, ByVal _
        dwFileAttributes As Long, psfi As SHFILEINFO, ByVal _
        cbFileInfo As Long, ByVal uFlags As Long) As LongPrivate Declare Function SHGetPathFromIDList Lib "shell32.dll" _
        Alias "SHGetPathFromIDListA" (ByVal pIdl As Long, ByVal _
        pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)Private Const BIF_RETURNONLYFSDIRS = &H1 ' For finding a folder to start document searching
Private Const BIF_DONTGOBELOWDOMAIN = &H2 ' For starting the Find Computer
Private Const BIF_STATUSTEXT = &H4
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_EDITBOX = &H10
Private Const BIF_VALIDATE = &H20 ' insist on valid result (or CANCEL)Private Const BIF_BROWSEFORCOMPUTER = &H1000  ' Browsing for Computers.
Private Const BIF_BROWSEFORPRINTER = &H2000   ' Browsing for Printers
Private Const BIF_BROWSEINCLUDEFILES = &H4000 ' Browsing for Everything
Private Type SHITEMID
    cb As Long
    abID() As Byte
End TypePrivate Type ITEMIDLIST
    mkid As SHITEMID
End TypePrivate 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 TypePrivate Enum ShellSpecialFolderConstants
    fDESKTOP = 0 '桌面
    fPROGRAMS = 2 '程序组
    fCONTROLS = 3 '控制面板
    fPRINTERS = 4 '打印机
    fPERSONAL = 5 '公文包
    fFAVORITES = 6 '收藏夹
    fSTARTUP = 7 '启动
    fRECENT = 8 '文档
    fSENDTO = 9 '发送
    fBITBUCKET = 10 '回收站
    fSTARTMENU = 11 '开始菜单
    fDESKTOPDIRECTORY = 16 '桌面文件夹
    fDRIVES = 17 '我的电脑
    fNETWORK = 18 '网上邻居
    fNETHOOD = 19 '
    fFONTS = 20 '字体
    fTEMPLATES = 21 '文档模板
End Enum
Private Type SHFILEINFO
    hIcon As Long
    iIcon As Long
    dwAttributes As Long
    szDisplayName As String * MAX_PATH
    szTypeName As String * 80
End TypePublic Function ShowBlowsDlg(ByVal lfrmhWnd As Long, ByVal sTitle As String) As String
    Dim BI As BROWSEINFO
    Dim nFolder As Long
    Dim IDL As ITEMIDLIST
    Dim pIdl As Long
    Dim sPath As String
    Dim SHFI As SHFILEINFO
    Dim sDisplayName As String
    With BI
        .hOwner = lfrmhWnd
        nFolder = fDESKTOP
        If SHGetSpecialFolderLocation(ByVal lfrmhWnd, ByVal nFolder, IDL) = 0 Then
            .pidlRoot = IDL.mkid.cb
        End If
        
        .pszDisplayName = String$(MAX_PATH, 0)
        .lpszTitle = sTitle
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With
  
    sDisplayName = ""
  
    pIdl = SHBrowseForFolder(BI)
  
    If pIdl = 0 Then Exit Function
    sPath = String$(MAX_PATH, 0)
    SHGetPathFromIDList ByVal pIdl, ByVal sPath
    sPath = Left(sPath, InStr(sPath, vbNullChar) - 1)
  
    sDisplayName = Left$(BI.pszDisplayName, _
                      InStr(BI.pszDisplayName, vbNullChar) - 1)
    CoTaskMemFree pIdl
    ShowBlowsDlg = sPath
End Function

Answer 2

http://ygyuan.go.163.com/
有源代码下载!

Answer 3

用Shell对象 BrowseForFolder 方法打开目录,好像确实不能指定初始目录!
得 API 回调 Init !才能指定初始目录!请问版主（acptvb)关于SHBrowseForFolder
http://www.csdn.net/expert/topic/269/269966.shtm

Answer 4

那我就贴出来吧!
新建一个工程，添加以下两个文件Form1.frm和Get Directory Dialog.bas.将以下文字保存为Form1.frm:
----------------------------------------------------------
VERSION 5.00
Begin VB.Form Form1 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "SHBrowseForFolder Demo"
   ClientHeight    =   1440
   ClientLeft      =   3630
   ClientTop       =   3585
   ClientWidth     =   7080
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1440
   ScaleWidth      =   7080
   Begin VB.TextBox Text1 
      Height          =   315
      Left            =   1560
      TabIndex        =   1
      Top             =   240
      Width           =   5295
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Browse For Folder"
      Height          =   435
      Left            =   2543
      TabIndex        =   0
      Top             =   780
      Width           =   1995
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "Current Directory:"
      Height          =   195
      Left            =   240
      TabIndex        =   2
      Top             =   240
      Width           =   1230
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option ExplicitPrivate getdir As String
'
'Private Sub Command1_Click()
    
    getdir = BrowseForFolder(Me, "Select A Directory", Text1.Text)
    If Len(getdir) = 0 Then Exit Sub  'user selected cancel
    Text1.Text = getdir
    
End SubPrivate Sub Form_Load()  Text1.Text = CurDirEnd Sub
-------------------------------------------------将以下文字保存为Get Directory Dialog.bas：------------------------------------------------------------------------
Option ExplicitPrivate Const BIF_STATUSTEXT = &H4&
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSELECTION = (WM_USER + 102)Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As LongPrivate Type BrowseInfo
  hWndOwner      As Long
  pIDLRoot       As Long
  pszDisplayName As Long
  lpszTitle      As Long
  ulFlags        As Long
  lpfnCallback   As Long
  lParam         As Long
  iImage         As Long
End TypePrivate m_CurrentDirectory As String   'The current directory
'Public Function BrowseForFolder(owner As Form, Title As String, StartDir As String) As String
  'Opens a Treeview control that displays the directories in a computer  Dim lpIDList As Long
  Dim szTitle As String
  Dim sBuffer As String
  Dim tBrowseInfo As BrowseInfo
  m_CurrentDirectory = StartDir & vbNullChar  szTitle = Title
  With tBrowseInfo
    .hWndOwner = owner.hWnd
    .lpszTitle = lstrcat(szTitle, "")
    .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_STATUSTEXT
    .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)  'get address of function.
  End With  lpIDList = SHBrowseForFolder(tBrowseInfo)
  If (lpIDList) Then
    sBuffer = Space(MAX_PATH)
    SHGetPathFromIDList lpIDList, sBuffer
    sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
    BrowseForFolder = sBuffer
  Else
    BrowseForFolder = ""
  End If
  
End Function
 
Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
  
  Dim lpIDList As Long
  Dim ret As Long
  Dim sBuffer As String
  
  On Error Resume Next  'Sugested by MS to prevent an error from
                        'propagating back into the calling process.
     
  Select Case uMsg
  
    Case BFFM_INITIALIZED
      Call SendMessage(hWnd, BFFM_SETSELECTION, 1, m_CurrentDirectory)
      
    Case BFFM_SELCHANGED
      sBuffer = Space(MAX_PATH)
      
      ret = SHGetPathFromIDList(lp, sBuffer)
      If ret = 1 Then
        Call SendMessage(hWnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
      End If
      
  End Select
  
  BrowseCallbackProc = 0
  
End Function' This function allows you to assign a function pointer to a vaiable.
Private Function GetAddressofFunction(add As Long) As Long
  GetAddressofFunction = add
End Function
------------------------------------------------------------------------