SHGetPathFromIDList does not return pathnames with leading periods - worksheet-function

Question

I have some Excel x64 VBA code that gets MP3 files, along with track#, size, length, etc., and puts them in some worksheets. The basic code came from John Walkenbach's page and can be found here: http://spreadsheetpage.com/index.php/file/mp3_file_lister/. I have modified it to run in 64-bit Excel by adding the PtrSafe keyword in the function declarations and changing some data types from Long to either LongLong or LongPtr (and maybe a few others). The code works wonderfully with one not too minor exception, it will not return any files in folders that contain leading periods. For example, I have an album by .38 Special ripped using WMP. The folder is: D:\Users\username\Music\Music.38 Special\Rock & Roll Strategy... This path does not appear in the list generated. I also have: D:\Users\username\Music\Music\Norah Jones...Featuring Nora Jones... and this folder is missing, too (the trailing ellipses represent the list of songs) . I have contacted John Walkenbach via email, and he has no idea why this is happening either.
Here is the code as I've modified it:
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
If anyone has any idea how to modify this so that pathnames containing a leading period as any part of the path can be returned, I'd be very glad to see it. I'd just rename those particular paths by removing the leading periods, but I'm afraid WMP will just one day put everything back the way it was (has happened before). Also, if you pick the actual folder in the BrowseForFolder API, that folder with the leading periods actually makes it into the sheet, but of course, only that folder.
Thanks

Answer 1

Look at this line in your code sample:
If Left$(FileName, 1) "." Then 'Current dir
Since the current directory is defined as a single '.' character, and this code only checks the initial character, it drops out before recursively examining it. Change the condition to check the length of the string as well as the initial character, e.g.
If (Left$(FileName, 1) = "." And FileName.Length = 1) Then 'Current dir
N.B. This code has not been tested; I hope it works for your use.

Answer 2

I was able to fix this by separating the test for root and subdirectory into separate IF statements, i.e.:
If filename <> "." Then
If filename <> ".." Then
*Code here*
End If
End If
Might be clunky, but it works.
The original If statement was:
If filename <> "." or filename <> ".." Then
This never worked. But then it occurred to me that maybe I needed to use a NAND statement. NAND = Not And. So I tried this:
if Not filename = "." And Not Filename = ".." then
This actually worked and seems to execute more rapidly than the earlier solution.

Answer 3

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
Also, other fileinfo items: 27 = duration, 28 = bit rate, 26 = track number.