ITPub博客

首页 > 应用开发 > IT综合 > 目录选择对话框 (转)

目录选择对话框 (转)

原创 IT综合 作者:amyz 时间:2007-10-14 15:25:53 0 删除 编辑
目录选择对话框 (转)[@more@]

Option Explicit

Private Type BrowseInfo
  lngHwnd  As Long
  pIDLroot  As Long
  pszDisplayName As Long
  lpszTitle  As Long
  ulFlags  As Long
  lpfnCallback  As Long
  lParam  As Long
  iImage  As Long
End Type

Private Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260

Private Declare Sub CoTaskMemFree Lib "ole32.dll" _
  (ByVal hMem As Long)

Private Declare Function lstrcat Lib "Kernel32" _
  Alias "lstrcatA" (ByVal lpString1 As String, _
  ByVal lpString2 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

Public Function BrowseForFolder(ByVal lngHwnd As Long, ByVal strPrompt As String) As String

  On Error GoTo ehBrowseForFolder 'Trap for errors

  Dim intNull As Integer
  Dim lngIDList As Long, lngResult As Long
  Dim strPath As String
  Dim udtBI As BrowseInfo

  'Set api properties (housed in a UDT)
  With udtBI
  .lngHwnd = lngHwnd
  .lpszTitle = lstrcat(strPrompt, "")
  .ulFlags = BIF_RETURNONLYFSDIRS
  End With

  'Display the browse folder...
  lngIDList = SHBrowseForFolder(udtBI)

  If lngIDList <> 0 Then
  'Create string of nulls so it will fill in with the path
  strPath = String(MAX_PATH, 0)

  'Retrieves the path selected, places in the null
  'character filled string
  lngResult = SHGetPathFromIDList(lngIDList, strPath)

  'Frees memory
  Call CoTaskMemFree(lngIDList)

  'Find the first instance of a null character,
  'so we can get just the path
  intNull = InStr(strPath, vbNullChar)
  'Greater than 0 means the path exists...
  If intNull > 0 Then
  'Set the value
  strPath = Left(strPath, intNull - 1)
  End If
  End If

  'Return the path name
  BrowseForFolder = strPath
  Exit Function 'Abort

ehBrowseForFolder:

  'Return no value
  BrowseForFolder = Empty

End Function


来自 “ ITPUB博客 ” ,链接:http://blog.itpub.net/10752019/viewspace-976606/,如需转载,请注明出处,否则将追究法律责任。

请登录后发表评论 登录
全部评论
  • 博文量
    3984
  • 访问量
    7339019