mdlfilefolder.bas

一款比较专业

End Type

Public Enum SpecialFolder
    CSIDL_RECENT = &H8
    CSIDL_PROFILER = &H28
    CSIDL_HISTORY = &H22
End Enum

Private Const BIF_NEWDIALOGSTYLE As Long = &H40
Private Const BIF_EDITBOX As Long = &H10
Private Const MAX_PATH As Integer = 260
Private Const SEE_MASK_INVOKEIDLIST = &HC
Private Const SEE_MASK_NOCLOSEPROCESS = &H40
Private Const SEE_MASK_FLAG_NO_UI = &H400
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_EXPLORER = &H80000
Private Const OFN_ENABLEHOOK = &H20
Private Const OFN_HIDEREADONLY = &H4
Private Const SHGFI_DISPLAYNAME As Long = &H200
Private Const SHGFI_TYPENAME As Long = &H400

Private Type SHFILEINFO
    hIcon As Long
    iIcon As Long
    dwAttributes As Long
    szDisplayName As String * MAX_PATH
    szTypeName As String * 80
End Type

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

Public Function BrowseForFolder(lnghwnd As Long, _
    strPrompt As String) As String
    On Error GoTo ehBrowseForFolder
    Dim intNull As Integer
    Dim lngIDList As Long, lngResult As Long
    Dim strPath As String
    Dim udtBI As BrowseInfo
    With udtBI
        .lnghwnd = lnghwnd
        .lpszTitle = lstrcat(strPrompt, "")
        .ulFlags = BIF_NEWDIALOGSTYLE + BIF_EDITBOX
    End With
    lngIDList = SHBrowseForFolder(udtBI)
    If lngIDList <> 0 Then
        strPath = String(MAX_PATH, 0)
        lngResult = SHGetPathFromIDList(lngIDList, _
            strPath)
        Call CoTaskMemFree(lngIDList)
        intNull = InStr(strPath, vbNullChar)
            If intNull > 0 Then
                strPath = Left(strPath, intNull - 1)
            End If
    End If
    BrowseForFolder = strPath
    Exit Function
ehBrowseForFolder:
    BrowseForFolder = Empty
End Function

Public Function GetSpecialFolder(FolderType As SpecialFolder) As String
    Dim R As Long, sPath As String
    Dim IDL As ITEMIDLIST
    R = SHGetSpecialFolderLocation(100, FolderType, IDL)
    sPath = Space$(512)
    R = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath)
    GetSpecialFolder = Left$(sPath, InStr(1, sPath, Chr$(0)) - 1)
End Function

Public Function GetWindowsPath() As String
    Dim lpBuffer As String * 255
    Dim nSize As Long
    nSize = GetWindowsDirectory(lpBuffer, 255)
    GetWindowsPath = Left(lpBuffer, nSize) & "\"
End Function

Public Function GetSystem32Path() As String
    Dim lpBuffer As String * 255
    Dim nSize As Long
    nSize = GetSystemDirectory(lpBuffer, 255)
    GetSystem32Path = Left(lpBuffer, nSize) & "\"
End Function

Public Function OpenInFolder(lvwItemExe As ListView, ItemId As Integer) As Double
    On Error Resume Next
    OpenInFolder = Shell("explorer.exe /select, " & _
        lvwItemExe.SelectedItem.SubItems(ItemId), vbNormalFocus)
End Function

Public Function OpenDosPrompt(lvwFilePath As ListView, _
    ItemExepath As Integer) As Long
    On Error Resume Next
    OpenDosPrompt = ShellExecute(1, vbNullString, "command.com", _
        vbNullString, GetFilePath(lvwFilePath.SelectedItem.SubItems(ItemExepath)), 1)
End Function

Public Function ShowRunApp(hwnd As Long) As Long
    On Error Resume Next
    ShowRunApp = SHRunDialog(hwnd, 0, 0, _
        StrConv("创建新进程", vbUnicode), _
        StrConv("Windows将根据您所输入的名称，为你打开相应的程序、文件夹、Internet资源。", vbUnicode), 0)
End Function

Public Function OpenXPTool(hwnd As Long, lpOperation As String) As Long
    On Error Resume Next
    OpenXPTool = ShellExecute(hwnd, vbNullString, lpOperation, _
        vbNullString, Left(GetWindowsPath, 3), 1)
End Function

Public Function OnlineHelp(hwnd As Long, strSite As String) As Long
    On Error Resume Next
    OnlineHelp = ShellExecute(hwnd, vbNullString, _
        "http://" & strSite, vbNullString, Left(GetWindowsPath, 3), 1)
End Function

Public Function ShowFileProperties(hwndOwner As Long, _
    lvwFilePath As ListView, ItemExepath As Integer, _
    Optional lUseSubItem As Boolean = True) _
     As Long
    On Error Resume Next
    Dim SEI As SHELLEXECUTEINFO
    Dim slpFileName As String
    If lUseSubItem Then
        slpFileName = lvwFilePath.SelectedItem.SubItems(ItemExepath)
    Else
        slpFileName = lvwFilePath.SelectedItem
    End If
    With SEI
        .cbSize = Len(SEI)
        .fMask = SEE_MASK_NOCLOSEPROCESS Or _
            SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI
        .hwnd = hwndOwner
        .lpVerb = "properties"
        .lpFile = slpFileName
        .lpParameters = vbNullChar
        .lpDirectory = vbNullChar
        .nShow = 0
        .hInstApp = 1
        .lpIDList = 0
    End With
    Call ShellExecuteEx(SEI)
End Function

Public Function GetFilePath(sPath As String) As String
    Dim i As Integer
    For i = Len(sPath) To 1 Step -1
        If Mid$(sPath, i, 1) = "\" Then
            GetFilePath = Mid$(sPath, 1, i)
            Exit For
        End If
    Next i
End Function

Public Function GetPathType(Path As String) As String
    Dim FileInfo As SHFILEINFO, lngRet As Long
    lngRet = SHGetFileInfo(Path, 0, FileInfo, _
        Len(FileInfo), SHGFI_DISPLAYNAME Or SHGFI_TYPENAME)
    If lngRet = 0 Then GetPathType = _
        Trim$(GetFileExtension(Path) & " File"): Exit Function
    GetPathType = Left$(FileInfo.szTypeName, _
        InStr(1, FileInfo.szTypeName, vbNullChar) - 1)
End Function

Public Function GetFileExtension(Path As String) As String
    Dim intRet As Integer: intRet = InStrRev(Path, ".")
    If intRet = 0 Then Exit Function
    GetFileExtension = UCase(Mid$(Path, intRet + 1))
End Function