SHGetPathFromIDList不返回带有前导句号的路径名

Question

我有一些Excel x64 VBA代码，可获取MP3文件以及音轨号，大小，长度等，并将它们放在一些工作表中。基本代码来自John Walkenbach的页面，可以在这里找到：http://spreadsheetpage.com/index.php/file/mp3_file_lister/。我通过在函数声明中添加PtrSafe关键字并将某些数据类型从Long更改为LongLong或LongPtr（也许还有其他一些），将其修改为在64位Excel中运行。该代码可以很好地运行，但有一个不太小的例外，它将不会返回包含前导期间的文件夹中的任何文件。例如，我有一个使用WMP翻录的.38 Special专辑。文件夹为：D：\ Users \ username \ Music \ Music.38 Special \ Rock＆Roll Strategy ...此路径未出现在生成的列表中。我也有：D：\ Users \ username \ Music \ Music \ Norah Jones ... Featureing Nora Jones ...并且此文件夹也丢失了（结尾的省略号代表歌曲列表）。我已经通过电子邮件联系了约翰·沃肯巴赫，他也不知道为什么会这样。

这是我修改后的代码：

Option Explicit
Dim Sht1Row As Integer
Dim Sht2Row As Integer

' By John Walkenbach
' Maybe be distributed freely, but not sold

'API declarations
Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As LongPtr

Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPtr

Public Type BROWSEINFO
  hOwner As LongPtr
  pidlRoot As LongPtr
  pszDisplayName As String
  lpszTitle As String
  ulFlags As LongPtr
  lpfn As LongPtr
  lParam As LongPtr
  iImage As LongPtr
End Type

Sub GetAllFiles()
    Dim Msg As String
    Dim Directory As String
    Dim lastRow1C As Integer
    Dim lastRow2C As Integer
    Dim lastRow1D As Integer
    Dim lastRow2D As Integer

    Msg = "Select the directory that contains the MP3 files. All subdirectories will be included."
    Directory = GetDirectory(Msg)
    If Directory = "" Then Exit Sub
    If Right(Directory, 1)  "\" Then Directory = Directory & "\"
        With Sheet1
            lastRow1C = .Cells(.Rows.Count, "C").End(xlUp).Row
            If lastRow1C  lastRow2D Then
            .Range("D" & lastRow2D, "F" & lastRow2D).Select
            Selection.AutoFill Destination:=Range("D" & lastRow2D, "F" & lastRow2C)
        End If
        .Range("E2:E" & lastRow2C).Copy
        .Range("A2:A" & lastRow2C).PasteSpecial xlPasteValues
        Columns("A:J").Sort key1:=Range("G2"), order1:=xlAscending, key2:=Range("H2"), order2:=xlAscending, Header:=xlYes
        Range("A1").Select
    End With

    With Sheet1
        Worksheets("Music_Library_Full").Activate
        lastRow1C = .Cells(.Rows.Count, "C").End(xlUp).Row
        lastRow1D = .Cells(.Rows.Count, "D").End(xlUp).Row
        If lastRow1C > lastRow1D Then
            .Range("D" & lastRow1D, "F" & lastRow1D).Select
            Selection.AutoFill Destination:=Range("D" & lastRow1D, "F" & lastRow1C)
        End If
        .Range("E2:E" & lastRow1C).Copy
        .Range("A2:A" & lastRow1C).PasteSpecial xlPasteValues
         Columns("A:J").Sort key1:=Range("G2"), order1:=xlAscending, key2:=Range("H2"), order2:=xlAscending, Header:=xlYes
        Range("A1").Select
    End With

Application.ScreenUpdating = True

End Sub

Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As String
    Dim x As String
    Dim pos As Integer
'   Root folder = Desktop
    bInfo.pidlRoot = 0&
'   Title in the dialog
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
    End If
'   Type of directory to return
    bInfo.ulFlags = &H1
'   Display the dialog
    x = SHBrowseForFolder(bInfo)
'   Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function

Public Sub RecursiveDir(ByVal currdir As String)
    Dim Dirs() As Variant
    Dim NumDirs As Long
    Dim FileName As String
    Dim PathAndName As String
    Dim i As Long
    Dim PathName As String
    Dim TrackNum As Variant
    Dim Genre As String
    Dim Duration As Variant
    Dim FileSize As Variant

'   Make sure path ends in backslash
    If Right(currdir, 1)  "\" Then currdir = currdir & "\"

'   Put column headings on active sheet
Worksheets("Music_Library_Full").Activate
    Cells(1, 1) = "Artist & Filename Lookup"
    Cells(1, 2) = "Filename Lookup"
    Cells(1, 3) = "Full Pathname"
    Cells(1, 4) = "Artist"
    Cells(1, 5) = "Artist & Filename"
    Cells(1, 6) = "Filename"
    Cells(1, 7) = "Path"
    Cells(1, 8) = "Track#"
    Cells(1, 9) = "Duration"
    Cells(1, 10) = "Size"
    Range("1:1").Font.Bold = True
    Range("1:1").Font.Italic = True
    Range("1:1").Font.Name = "Consolas"

Worksheets("Best_Greatest").Activate
    Cells(1, 1) = "Artist & Filename Lookup"
    Cells(1, 2) = "Filename Lookup"
    Cells(1, 3) = "Full Pathname"
    Cells(1, 4) = "Artist"
    Cells(1, 5) = "Artist & Filename"
    Cells(1, 6) = "Filename"
    Cells(1, 7) = "Path"
    Cells(1, 8) = "Track#"
    Cells(1, 9) = "Duration"
    Cells(1, 10) = "Size"
    Range("1:1").Font.Bold = True
    Range("1:1").Font.Italic = True
    Range("1:1").Font.Name = "Consolas"

'   Get files
    FileName = Dir(currdir & "*.*", vbDirectory)

    Do While Len(FileName)  0
      If Left$(FileName, 1)  "." Then 'Current dir
        PathAndName = currdir & FileName
        If (GetAttr(PathAndName) And vbDirectory) = vbDirectory Then
          'store found directories
           ReDim Preserve Dirs(0 To NumDirs) As Variant
           Dirs(NumDirs) = PathAndName
           NumDirs = NumDirs + 1
        Else
            If UCase(Right(FileName, 3)) = "MP3" Then
                PathName = currdir 'path
                FileName = FileName 'filename
                TrackNum = FileInfo(currdir, FileName, 26) 'track
                Duration = FileInfo(currdir, FileName, 27) 'duration
                FileSize = Application.Round(FileLen(currdir & FileName) / 1024, 0) 'size
                'Application.StatusBar = Row
                If InStr(1, LCase(PathName), LCase("Best of"), vbTextCompare) Or InStr(1, LCase(PathName), LCase("Greatest"), vbTextCompare) Then
                    'Sht2Row = WorksheetFunction.CountA(Range("C:C")) + 1
                    Worksheets("Best_Greatest").Activate
                    Cells(Sht2Row, 2) = FileName
                    Cells(Sht2Row, 3) = PathName & FileName
                    Cells(Sht2Row, 7) = PathName
                    Cells(Sht2Row, 8) = TrackNum
                    Cells(Sht2Row, 9) = Duration
                    Cells(Sht2Row, 10) = FileSize
                    Sht2Row = Sht2Row + 1
                Else
                    'Sht1Row = WorksheetFunction.CountA(Range("C:C")) + 1
                    Worksheets("Music_Library_Full").Activate
                    Cells(Sht1Row, 2) = FileName
                    Cells(Sht1Row, 3) = PathName & FileName
                    Cells(Sht1Row, 7) = PathName
                    Cells(Sht1Row, 8) = TrackNum
                    Cells(Sht1Row, 9) = Duration
                    Cells(Sht1Row, 10) = FileSize
                    Sht1Row = Sht1Row + 1
                End If
            End If
        End If
    End If
        FileName = Dir()
    Loop
    ' Process the found directories, recursively
    For i = 0 To NumDirs - 1
        RecursiveDir Dirs(i)
    Next i
End Sub

Function FileInfo(path, FileName, item) As Variant
    Dim objShell As IShellDispatch4
    Dim objFolder As Folder3
    Dim objFolderItem As FolderItem2

    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(path)
    Set objFolderItem = objFolder.ParseName(FileName)
    FileInfo = objFolder.GetDetailsOf(objFolderItem, item)

    Set objShell = Nothing
    Set objFolder = Nothing
    Set objFolderItem = Nothing
End Function

[如果有人知道如何修改此名称，以便可以返回包含前导句作为路径的任何部分的路径名，我将非常高兴看到它。我只是通过删除前置时间来重命名那些特定的路径，但是恐怕WMP只会在一天之内将一切恢复原状（以前发生过）。另外，如果您在BrowseForFolder API中选择实际的文件夹，则该带有前导句号的文件夹实际上会进入工作表，但当然只有该文件夹。谢谢

Answer 1

查看代码示例中的此行：

如果为Left $（FileName，1）“。然后“当前目录

由于当前目录被定义为单个'。字符，并且此代码仅检查初始字符，在递归检查之前将其删除。将条件更改为检查字符串的长度以及初始字符，例如

如果（Left $（FileName，1）=“。” And FileName.Length = 1）然后'当前目录

N.B。此代码尚未经过测试；希望它对您有用。

Answer 2

我能够通过将根目录和子目录的测试分成单独的IF语句来解决此问题，即：

    If filename <> "." Then
        If filename <> ".." Then
            *Code here*
        End If
    End If

可能笨拙，但是有效。

原始的If语句是：

如果文件名<>“。”或文件名<>“ ..”然后

这没用。但是后来我想到也许我需要使用NAND语句。 NAND =不与。所以我尝试了这个：

如果不是filename =“。”而不是Filename =“ ..”然后

此方法确实有效，并且似乎比早期的解决方案执行得更快。

Answer 3

显式期权约翰·沃肯巴赫'可以自由分发，但不出售子GetAllFiles（）昏暗的消息作为字符串昏暗目录Msg =“选择包含MP3文件的目录。将包含所有子目录。设置目录= Application.FileDialog（msoFileDialogFolderPicker）带目录。标题=消息.AllowMultiSelect =假。显示如果.SelectedItems.Count> 0然后目录= .SelectedItems.item（1）其他退出子万一结束于如果为Right（Directory，1）<>“ \”，则Directory = Directory＆“ \”工作表（“ Sheet1”）。激活细胞清除'将列标题放在活动工作表上单元格（1，1）=“路径”Cells（1，2）=“文件名”单元格（1，3）=“全路径”Cells（1，4）=“艺术家”单元格（1，5）=“相册”单元格（1，6）=“标题”单元格（1，7）=“ Track＃”Cells（1，8）=“流派”单元格（1，9）=“持续时间”单元格（1，10）=“年份”单元格（1，12）=“大小”Range（“ 1：1”）。Font.Bold = True呼叫RecursiveDir（目录）结束子公共子RecursiveDir（ByVal currdir作为字符串）Dim Dirs（）作为变体昏暗的数字昏暗的文件名作为字符串昏暗的PathAndName作为字符串变暗变暗行作为变体'确保路径以反斜杠结尾如果为Right（currdir，1）<>“ \”，则currdir = currdir＆“ \”Application.ScreenUpdating = False'获取文件文件名= Dir（currdir＆“ *。*”，vbDirectory）做While Len（文件名）<> 0活动事件如果不是filename =“。”。而且不是filename =“ ..”然后是'当前目录PathAndName = currdir和文件名如果（GetAttr（PathAndName）And vbDirectory）= vbDirectory，则'存储找到的目录ReDim将Dirs（0到NumDirs）保留为变体Dirs（NumDirs）=路径和名称NumDirs = NumDirs + 1其他如果UCase（Right（filename，3））=“ MP3”，则行= WorksheetFunction.CountA（Range（“ A：A”））+ 1单元格（行，1）= currdir'路径单元格（行，2）=文件名'文件名单元格（行3）= PathAndNameCells（Row，4）= FileInfo（currdir，filename，20）'artistCells（Row，5）= FileInfo（currdir，filename，14）'专辑Cells（Row，6）= FileInfo（currdir，filename，21）'标题Cells（Row，7）= FileInfo（currdir，filename，26）'trackCells（Row，8）= FileInfo（currdir，filename，16）'genreCells（Row，9）= FileInfo（currdir，filename，27）'持续时间Cells（Row，10）= FileInfo（currdir，filename，15）'年单元格（行11）= FileInfo（currdir，文件名5）Cells（Row，12）= Application.Round（FileLen（currdir＆filename）/ 1024，0）'sizeApplication.StatusBar =行万一万一万一文件名= Dir（）环'递归处理找到的目录对于i = 0至NumDirs-1递归Dir Dirs（i）接下来我Application.StatusBar = False结束子函数FileInfo（路径，文件名，项目）为变体昏暗的objShell作为IShellDispatch4暗objFolder作为Folder3昏暗的objFolderItem作为FolderItem2设置objShell = CreateObject（“ Shell.Application”）设置objFolder = objShell.Namespace（path）设置objFolderItem = objFolder.ParseName（文件名）FileInfo = objFolder.GetDetailsOf（objFolderItem，项目）设置objShell = Nothing设置objFolder = Nothing设置objFolderItem = Nothing结束功能

另外，其他文件信息项：27 =持续时间，28 =比特率，26 =音轨号。

Answer 4

无法设置“作曲家”。编辑命令不起作用。请建议添加作曲家和/或专辑艺术家