modbrowsefolder.bas

超经典的打印预览动态库源码 版权： 本资源版权归作者所有 说明： 本资源由源码天空搜集,仅提供学习参考

Attribute VB_Name = "ModBrowseFolder"

Option Explicit

'**************************************************************
'*模块名称：ModBrowseFolder
'*模块功能：浏览文件夹
'*说明：
'*
'*备注：
'*
'*作者：chlf78
'*日期：2002-04-10 15:38:07
'***************************************************************

Private Const ModalName = "ModBrowseFolder"

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
    Dim 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

ehBrowseForFolder:
    BrowseForFolder = Empty
End Function