我有一些Excel x64 VBA代码可以获取MP3文件，以及曲目＃，大小，长度等，并将它们放在一些工作表中。基本代码来自John Walkenbach的页面，可在此处找到：http://spreadsheetpage.com/index.php/file/mp3_file_lister/。我已经修改它以在64位Excel中运行，方法是在函数声明中添加PtrSafe关键字，并将一些数据类型从Long更改为LongLong或LongPtr（可能还有其他一些）。代码可以很好地使用一个不太小的异常，它不会返回包含前导句点的文件夹中的任何文件。例如，我有一张使用WMP的.38 Special专辑。该文件夹是：D：\ Users \ username \ Music \ Music.38 Special \ Rock＆amp; Roll Strategy ...此路径未出现在生成的列表中。我也有：D：\ Users \用户名\音乐\音乐\ Norah Jones ...以Nora Jones为特色......此文件夹也缺失（尾随的省略号表示歌曲列表）。我通过电子邮件联系了John Walkenbach，他也不知道为什么会发生这种情况。
以下是我修改过的代码：
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中选择实际文件夹，那么带有前导句点的文件夹实际上会进入工作表，但当然只有该文件夹。 感谢
答案 0 :(得分：1)
在代码示例中查看以下行：
如果左$（FileName，1）＆＃34;。＆＃34;那么＆＃39;当前目录
由于当前目录被定义为单个＆＃39;。＆＃39;字符，此代码仅检查初始字符，在递归检查之前它会丢失。将条件更改为检查字符串的长度以及初始字符，例如
如果（左$（FileName，1）=＆＃34;。＆＃34;和FileName.Length = 1）那么＆＃39;当前目录
N.B。此代码尚未经过测试;我希望它适合您的使用。
答案 1 :(得分：0)
我能够通过将root和子目录的测试分成单独的IF语句来解决这个问题，即：
If filename <> "." Then
If filename <> ".." Then
*Code here*
End If
End If
可能很笨重但是有效。
原来的If声明是：
If filename <> "." or filename <> ".." Then
这从未奏效。但后来我想到也许我需要使用NAND声明。 NAND =不和。所以我尝试了这个：
if Not filename = "." And Not Filename = ".." then
这实际上有效，并且似乎比早期解决方案执行得更快。
答案 2 :(得分：0)
Option Explicit
' By John Walkenbach
' Maybe be distributed freely, but not sold
Sub GetAllFiles()
Dim Msg As String
Dim Directory
Msg = "Select the directory that contains the MP3 files. All subdirectories will be included."
Set Directory = Application.FileDialog(msoFileDialogFolderPicker)
With Directory
.Title = Msg
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
Directory = .SelectedItems.item(1)
Else
Exit Sub
End If
End With
If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
Worksheets("Sheet1").Activate
Cells.Clear
' Put column headings on active sheet
Cells(1, 1) = "Path"
Cells(1, 2) = "Filename"
Cells(1, 3) = "FullPath"
Cells(1, 4) = "Artist"
Cells(1, 5) = "Album"
Cells(1, 6) = "Title"
Cells(1, 7) = "Track#"
Cells(1, 8) = "Genre"
Cells(1, 9) = "Duration"
Cells(1, 10) = "Year"
Cells(1, 12) = "Size"
Range("1:1").Font.Bold = True
Call RecursiveDir(Directory)
End Sub
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 Variant
Dim Row As Variant
' Make sure path ends in backslash
If Right(currdir, 1) <> "\" Then currdir = currdir & "\"
Application.ScreenUpdating = False
' Get files
filename = Dir(currdir & "*.*", vbDirectory)
Do While Len(filename) <> 0
DoEvents
If Not filename = "." And Not filename = ".." 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
Row = WorksheetFunction.CountA(Range("A:A")) + 1
Cells(Row, 1) = currdir 'path
Cells(Row, 2) = filename 'filename
Cells(Row, 3) = PathAndName
Cells(Row, 4) = FileInfo(currdir, filename, 20) 'artist
Cells(Row, 5) = FileInfo(currdir, filename, 14) 'album
Cells(Row, 6) = FileInfo(currdir, filename, 21) 'title
Cells(Row, 7) = FileInfo(currdir, filename, 26) 'track
Cells(Row, 8) = FileInfo(currdir, filename, 16) 'genre
Cells(Row, 9) = FileInfo(currdir, filename, 27) 'duration
Cells(Row, 10) = FileInfo(currdir, filename, 15) 'Year
Cells(Row, 11) = FileInfo(currdir, filename, 5)
Cells(Row, 12) = Application.Round(FileLen(currdir & filename) / 1024, 0) 'size
Application.StatusBar = Row
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
Application.StatusBar = False
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
此外，其他fileinfo项目：27 =持续时间，28 =比特率，26 =轨道号。