5
\$\begingroup\$

I was inspired to throw this class together by an SO question and thought I'd subject it to some welcome criticism here.

The class is basically just a wrapper around the shell utility dir, and is intended as a replacement for the built in Dir$ function. The rationale for replacing the function is that it has many more features than either the built in VBA functionality or the Scripting.FileSystemObject when it comes to directory listings. For example, Dir$ won't recurse subdirectories, Scripting.FileSystemObject won't take wildcards, and neither of them will filter for file attributes or sort the output. This class serves to fill that gap.

Disclaimer: This is essentially a rough draft waiting to be extended. Known limitations include:

  • It doesn't test for conflicting attribute or sort flags. The dir utility doesn't either, but an extension should probably extend. This gives it slightly different behaviour because the parameter order is the tie breaker for dir.
  • It should probably have the option to specify whether or not to return the full path as opposed to the just the file. The behaviour currently depends on whether the RecurseSubDirectories property is set to True or False (just like dir, but again the ultimate goal is to extend).
  • The command window popping up from the WScript.Shell.Exec call is annoying. This will likely require some future API hacks.
  • Other things I'm not thinking of. ;-)

All code other than the usage example is in DirectoryListing.cls.


Header: The FileAttributes and SortOrder enumerations are used as flags. TimeField values can't be combined, so they are a straight up Enum. There's probably some room for criticism here...

Option Explicit

Public Enum FileAttributes
    Default = 0
    HiddenFiles = 2 ^ 0
    NonHiddenFiles = 2 ^ 1
    SystemFiles = 2 ^ 2
    NonSystemFiles = 2 ^ 3
    DirectoriesOnly = 2 ^ 4
    FilesOnly = 2 ^ 5
    ArchiveReady = 2 ^ 6
    NonArchiveReady = 2 ^ 7
    ReadOnly = 2 ^ 8
    NonReadOnly = 2 ^ 9
End Enum

Public Enum SortOrder
    Default = 0
    NameAscending = 2 ^ 0
    NameDescending = 2 ^ 1
    ExtensionAscending = 2 ^ 2
    ExtensionDescending = 2 ^ 3
    TimeAscending = 2 ^ 4
    TimeDescending = 2 ^ 5
    SizeAscending = 2 ^ 6
    SizeDescending = 2 ^ 7
    DirectoriesFirst = 2 ^ 8
    DirectoriesLast = 2 ^ 9
End Enum

Public Enum TimeField
    Default = 0
    Creation = 1
    LastAccess = 2
    LastWritten = 3
End Enum

Private mPath As String
Private mSort As SortOrder
Private mAttribs As FileAttributes
Private mTime As TimeField
Private mRecurse As Boolean
Private mShort As Boolean

Private Const BASE_COMMAND = "cmd /c dir "

Properties: I'm not sure if I like the "flag" properties as Let and Get. Add*Flag, Has*Flag, and Remove*Flag might be better. Opinions are obviously welcome.FilePath is read only because it is intended to only be set by the passed parameter to Execute (and is probably misnamed - again, suggestions are welcome).

Public Property Get FilePath() As String
    FilePath = mPath
End Property

Public Property Let SortFlags(ByVal value As SortOrder)
    mSort = value
End Property

Public Property Get SortFlags() As SortOrder
    SortFlags = mSort
End Property

Public Property Let AttributeFlags(ByVal value As FileAttributes)
    mAttribs = value
End Property

Public Property Get AttributeFlags() As FileAttributes
    AttributeFlags = mAttribs
End Property

Public Property Let SortTimeField(ByVal value As TimeField)
    mTime = value
End Property

Public Property Get SortTimeField() As TimeField
    SortTimeField = mTime
End Property

Public Property Let RecurseSubDirectories(ByVal value As Boolean)
    mRecurse = value
End Property

Public Property Get RecurseSubDirectories() As Boolean
    RecurseSubDirectories = mRecurse
End Property

Public Property Let ShortFileNames(ByVal value As Boolean)
    mShort = value
End Property

Public Property Get ShortFileNames() As Boolean
    ShortFileNames = mShort
End Property

Internal Functionality: Just a couple of helper functions to convert the enumeration values into the command line options:

Private Function SortArguments() As String
    If SortFlags = SortOrder.Default Then
        SortArguments = vbNullString
        Exit Function
    End If

    With New Scripting.Dictionary
        If mSort And NameAscending Then .Add "n", vbNull
        If mSort And NameDescending Then .Add "-n", vbNull
        If mSort And ExtensionAscending Then .Add "e", vbNull
        If mSort And ExtensionDescending Then .Add "-e", vbNull
        If mSort And TimeAscending Then .Add "d", vbNull
        If mSort And TimeDescending Then .Add "-d", vbNull
        If mSort And SizeAscending Then .Add "s", vbNull
        If mSort And SizeDescending Then .Add "-s", vbNull
        If mSort And DirectoriesFirst Then .Add "g", vbNull
        If mSort And DirectoriesLast Then .Add "-g", vbNull
        SortArguments = " /o:" & Join(.Keys, vbNullString)
    End With
End Function

Private Function AttributeArguments() As String
    If AttributeFlags = SortOrder.Default Then
        AttributeArguments = vbNullString
        Exit Function
    End If

    With New Scripting.Dictionary
        If mAttribs And HiddenFiles Then .Add "h", vbNull
        If mAttribs And NonHiddenFiles Then .Add "-h", vbNull
        If mAttribs And SystemFiles Then .Add "s", vbNull
        If mAttribs And NonSystemFiles Then .Add "-s", vbNull
        If mAttribs And DirectoriesOnly Then .Add "d", vbNull
        If mAttribs And FilesOnly Then .Add "-d", vbNull
        If mAttribs And ArchiveReady Then .Add "a", vbNull
        If mAttribs And NonArchiveReady Then .Add "-a", vbNull
        If mAttribs And ReadOnly Then .Add "r", vbNull
        If mAttribs And NonReadOnly Then .Add "-r", vbNull
        AttributeArguments = " /a:" & Join(.Keys, vbNullString)
    End With
End Function

Private Function TimeArgument() As String
    Select Case SortTimeField
        Case TimeField.Default
            TimeArgument = vbNullString
        Case Creation
            TimeArgument = " /t:c"
        Case LastAccess
            TimeArgument = " /t:a"
        Case LastWritten
            TimeArgument = " /t:w"
    End Select
End Function

The Sole Method: When passed a file path, it performs a dir on it. Supports ? and * wildcards:

Public Function Execute(ByVal dirPath As String) As String()
    mPath = dirPath
    Dim command As String
    command = BASE_COMMAND & """" & dirPath & """ /b " & SortArguments & _
              AttributeArguments & TimeArgument

    If mRecurse Then command = command & " /s"
    If mShort Then command = command & " /x"

    With CreateObject("WScript.Shell")
        With .Exec(command).StdOut
            Dim output As String
            Dim arrayBound As Long
            Dim results() As String
            results = Split(vbNullString)

            Do While Not .AtEndOfStream
                output = .ReadLine
                If output <> vbNullString Then
                    arrayBound = UBound(results) + 1
                    ReDim Preserve results(arrayBound)
                    results(arrayBound) = output
                End If
            Loop
        End With
    End With

    Execute = results
End Function

Usage example:

'Displays all System32 .dll files in descending order by creation time.
With New DirectoryListing
    .SortFlags = TimeDescending
    .AttributeFlags = FilesOnly
    Dim result() As String
    result = .Execute("C:\Windows\System32\*.dll")
    Dim i As Long
    For i = LBound(result) To UBound(result)
        Debug.Print result(i)
    Next i
End With
\$\endgroup\$
  • 1
    \$\begingroup\$ This is going to be so useful. \$\endgroup\$ – Kaz Sep 1 '16 at 8:18
2
\$\begingroup\$
Private Const BASE_COMMAND = "cmd /c dir "

The constant declaration doesn't have an explicit type; this would trigger an inspection result with Rubberduck; applying thhe quickfix would turn the declaration into this:

Private Const BASE_COMMAND As String = "cmd /c dir "

It's debatable whether explicitly assigning the return value has any use here:

If SortFlags = SortOrder.Default Then
    SortArguments = vbNullString
    Exit Function
End If

The result would be the same without the assignment... on the other hand, it's a good practice to have all code paths return a value, be it only for the love of explicitness.

Same here:

If AttributeFlags = SortOrder.Default Then
    AttributeArguments = vbNullString
    Exit Function
End If

...except there's a minor little copy-pasta error here - SortOrder.Default should be FileAttributes.Default! ..but it's no biggie because both values are 0.

The naming of enum types isn't consistent - flag enums should have a plural name:

Public Enum FileAttributes 'correct
    Default = 0
    HiddenFiles = 2 ^ 0
    NonHiddenFiles = 2 ^ 1
    SystemFiles = 2 ^ 2
    '...
End Enum

Public Enum SortOrder 'how does client code know they can be combined?
    Default = 0
    NameAscending = 2 ^ 0
    NameDescending = 2 ^ 1
    ExtensionAscending = 2 ^ 2
    '...
End Enum

Public Enum TimeField 'ok
    Default = 0
    Creation = 1
    LastAccess = 2
    LastWritten = 3
End Enum

I have no problem with TimeField or its values. Perhaps better names could be FileAttributeFlags and SortOrderFlags for the two flag enum types? I have no neat solution for the mutually exclusive sort flag values though, other than proper validation and error-raising in Property Let SortFlags.

The TimeField enum member values don't need to be explicit (they're assigned to the default values anyway).

SortOrder values come in mutually exclusive pairs, so there should be some validation logic in the Property Let SortFlags member, to raise an error that tells the client code when it tries to set the NameAscending flag when NameDescending is already set.

Public Property Let SortFlags(ByVal value As SortOrder)
    ThrowOnConflictingSortFlags value
    mSort = value
End Property

Private Sub ThrowOnConflictingSortFlags(ByVal value As SortOrder)
    'this is where short-circuiting logical operators would be nice...
    If HasFlag(value, NameAscending + NameDescending) Then OnConflictingFlagsError NameAscending, NameDescending
    If HasFlag(value, ExtensionAscending + ExtensionDescending) Then OnConflictingFlagsError ExtensionAscending, ExtensionDescending
    If HasFlag(value, TimeAscending + TimeDescending) Then OnConflictingFlagsError TimeAscending, TimeDescending
    If HasFlag(value, SizeAscending + SizeDescending) Then OnConflictingFlagsError SizeAscending, SizeDescending
    If HasFlag(value, DirectoriesFirst, DirectoriesLast) Then OnConflictingFlagsError DirectoriesFirst, DirectoriesLast
End Sub

Private Sub OnConflictingFlagsError(ByVal flag1 As SortOrder, ByVal flag2 As SortOrder)
    'something like this could work I guess
    Err.Raise 5, TypeName(Me), "Specified sort order flags values " & flag1 & " and " & flag2 & " are mutually exclusive."
End Sub

Private Function HasFlag(ByVal value As Long, ByVal flag As Long) As Boolean
    HasFlag = (value And flag) = flag
End Function

Such a HasFlag function could very well be reused to simplify SortArguments and AttributeArguments functions, too.

\$\endgroup\$
  • 1
    \$\begingroup\$ Yeah, the naming part of my brain wasn't working when I wrote it... although I always debate myself as to whether flag enums should be plural or singular. The Easter egg copy paste error is still undiscovered... \$\endgroup\$ – Comintern Sep 2 '16 at 23:15
  • \$\begingroup\$ @Comintern I would consider making Mug's HasFlag a public "static" method, maybe move it into a module. I personally like the properties as they are. It makes the code much less verbose than a bunch of AddFlags would be. Take it with a grain of salt though, I've been spending my time bit-twiddling register values on a microcontroller lately. The AddFlag methods may be easier for average joe VBA dev to grok. \$\endgroup\$ – RubberDuck Sep 3 '16 at 11:43

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.