4
\$\begingroup\$

I am using Vba excel to populate a list of all my .wtv files using the .GetDetailsOf method. There are some 3000 files across 4 hard drives filed in a b c... subdirectories.

This sends my memory usage from just over 4 (normal) to nearly the full 8 GB available and halts my computer for a short time.

Is there a better method or something else i can set that doesn't force windows to open every file?

(This is a mash up of two codes on the net found here and here

Option Explicit
Sub GetDetails()





Cells.Select
Selection.ClearContents
Range("A1").Select

Dim fso, oFolder, oSubfolder, queue As Collection 'removed oFile,

Dim dirs As Variant
Dim oShell As Object
Dim oFile As Object
Dim oFldr As Object
Dim lRow As Long
Dim iCol As Integer

Dim fArray As Variant
fArray = Array("K:\Video_Store\Movies_a_k", "I:\Video_Store\Movies_j_r", "J:\Video_Store\Movies_The", "H:\Video_Store\Movies_s_z")
Dim vArray As Variant
vArray = Array(0, 21, 27, 1, 260, 15, 253, 261, 16, 259, 177, 19) 'removed
'0=Name, 21=Title, 27=length, 01=size, 260=recordingtime, 15=year, 253=channelno,
'261=stationcallsign, 16=genre, 259=progdesc, 177=path, 19=rating

Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection

lRow = 1

For dirs = LBound(fArray) To UBound(fArray)
    queue.Add fso.GetFolder(fArray(dirs)) 'obviously replace

    Do While queue.Count > 0
        Set oFolder = queue(1)
        queue.Remove 1 'dequeue
        '...insert any folder processing code here...
        For Each oSubfolder In oFolder.SubFolders
            queue.Add oSubfolder 'enqueue

            Set oShell = CreateObject("Shell.Application")
            Set oFldr = oShell.Namespace(CStr(oSubfolder))
                With oFldr
'                    For iCol = LBound(vArray) To UBound(vArray)
'                        Cells(lRow, iCol + 1) = .GetDetailsOf(.Items, vArray(iCol))
'                    Next iCol
                    For Each oFile In .Items
                        lRow = lRow + 1
                        For iCol = LBound(vArray) To UBound(vArray)
                            Cells(lRow, iCol + 1) = .GetDetailsOf(oFile, vArray(iCol))
                        Next iCol
                    Next oFile
                End With

        Next oSubfolder
'        For Each oFile In oFolder.Files
'            '...insert any file processing code here...
'        Next oFile
    Loop

Next dirs



End Sub

enter image description here

\$\endgroup\$
2
  • \$\begingroup\$ Does '...insert any folder processing code here... and '...insert any file processing code here... stand for actual code that's part of what the procedure is doing? Or it's just a comment? Please give us your real, actual code; a peer review that's done off partial code isn't half as useful as one that's off the real thing. \$\endgroup\$ Sep 27 '16 at 16:36
  • \$\begingroup\$ I believe all these processes are each oShell object you're creating in a (relatively) tight loop - already by instantiating it once and reusing 3000 times, I'm pretty sure you'll see quite an improvement. Yes, VBA is supposed to keep track of the reference counts, but having all these new instances in the same scope might be confusing it; the oShell reference is effectively repurposed at each iteration - ditto with oFldr. VBA being single-threaded, there's no reason for there to be more than 1 such process at any given time... if it's done right. \$\endgroup\$ Sep 27 '16 at 23:31
1
\$\begingroup\$

Your macro/procedure is implicitly working off the ActiveSheet: everywhere you use an unqualified Cells or Range, what VBA is seeing is ActiveSheet.Cells or ActiveSheet.Range: if you're supposed to work off Sheet1 or, if you gave it a code name, some DestinationSheet worksheet, use that instead, so that VBA doesn't need to resolve what the active sheet is every time you refer to it.

You should also avoid using .Select and .Activate and working off the Selection whenever possible.

The procedure is doing way too many things; break it down! You need a procedure whose role is to clear the contents of the DestinationSheet. Then you need a function that takes some rootPath and recursively returns all .wtv files under it and its subdirectories: you want to flatten that tree and work off a straight list of filenames to process (simply tweak that code to make it a Function and fill up and return some Collection instead of Debug.Printing as it goes). Seems your code will process any file, not just .wtv ones.


This is a missed opportunity:

Dim vArray As Variant
vArray = Array(0, 21, 27, 1, 260, 15, 253, 261, 16, 259, 177, 19) 'removed
'0=Name, 21=Title, 27=length, 01=size, 260=recordingtime, 15=year, 253=channelno,
'261=stationcallsign, 16=genre, 259=progdesc, 177=path, 19=rating

Consider declaring an Enum type here:

Private Enum FileInfoField
    Name = 0
    Size = 1
    Year = 15
    Genre = 16
    Rating = 19
    Title = 21
    Length = 27
    Path = 177
    Channel = 253
    ProgDesc = 259
    RecordingTime = 260
    StationCallsign = 261
End Enum

And now you can do away with these comments and mental mappings:

Dim infoFields As Variant
infoFields = Array(Name, Size, Year, Genre, Rating, Title, Length, Path, Channel, ProgDesc, RecordingTime, StationCallsign)

Note the identifier infoFields is much more descriptive than vArray which says essentially nothing other than "well it's a variant array", assuming the v is a Hungarian Notation prefix for "variant".

Because we've recursively found all files under a given root folder already, I don't think we need that queue overhead anymore.

Remember we're collecting the data at this point, so there won't be any Cells(lRow, iCol + 1) = assignment here. Instead we'll .GetDetailsOf each file and perhaps populate a data type - I'd add a class module here, to represent some "file info" data; the class doesn't need to be very complicated, it's just a "dumb data container", so a bunch of public fields can do:

Option Explicit

Public Name As String
Public Genre As String
Public Title As String
Public Size As String
'...

Or we can make it a little more than that, and embed some of the functionality in that class - in that case I'd opt for get-only properties instead, move the FileInfoField definition to that class module, and rename its members to avoid clashing identifiers - I'd call that class MovieFileInfo:

Option Explicit
Private Enum FileInfoField
    NameField = 0
    SizeField = 1
    YearField = 15
    GenreField = 16
    RatingField = 19
    TitleField = 21
    LengthField = 27
    PathField = 177
    ChannelField = 253
    ProgDescField = 259
    RecordingTimeField = 260
    StationCallsignField = 261
End Enum

Private Type TMovieFileInfo
    Name As String
    Genre As String
    Title As String
    Size As String
    '...
End Type

Private this As TMovieFileInfo

Public Property Get Name() As String
    Name = this.Name
End Property

Public Property Get Genre() As String
     Genre = this.Genre
End Property

Public Property Get Title() As String
    Title = this.Title
End Property

Public Property Get Size() As String
    Size = this.Size
End Property

'...

Public Sub LoadFrom(ByVal parentFolder As Shell32.Folder, ByVal info As Shell32.FolderItem)
    With parentFolder
        this.Name = .GetDetailsOf(info, NameField)
        this.Title = .GetDetailsOf(info, TitleField)
        this.Size = .GetDetailsOf(info, SizeField)
        this.Genre = .GetDetailsOf(info, GenreField)
        '...
    End With
End Sub

Back to your loops. oShell doesn't need to be re-created at every single iteration of the inner-inner loop; it can very well be declared and assigned before any looping is done, and destroyed after all loops complete. The oFldr reference could be held by the With block itself - instead of this:

Set oFldr = oShell.Namespace(CStr(oSubfolder))
With oFldr

You could have this:

With oShell.Namespace(subfolder.Path)

And then the object reference is gone at End With.

Notice Path is teh default property of a Scripting.Folder, so by doing CStr(oSubfolder) you're really just fetching its Path property.... quite indirectly.

I'd suggest you add an actual reference to the Microsoft Scripting Runtime and Microsoft Shell Controls and Automation libraries, and early-bind all those, and work with strongly-typed objects instead of Variant and Object, which are costing you lots of overhead here.

So, something like this (I think I'm getting confused with the actual involved types here though):

Dim item As MovieFileInfo
Dim info As Shell32.FolderItem
Dim allFiles As Collection
With oShell.Namespace(subfolder.Path)
    For Each info In subfolder.Items
        Set item = New MovieFileInfo
        item.LoadFrom subfolder, info
        allFiles.Add item
    Next
End With

Anyway, so you traverse your flat list of files and populate a collection of MovieFileInfo items.

Once you have that, you dimension an array large enough to fit all rows and all columns, and then you populate it by iterating your collection.

Once you have that 2D array, you just dump it onto the target worksheet in one, single, instant worksheet write.

Alternatively you could skip the MovieFileInfo part and write directly to the array, but the constant resizing to accomodate each new record might not be worth it.

So, to recap:

  • Reduce nesting by extracting loop body into specialized procedures/functions
  • Avoid writing to cells as much as possible
  • Early-bind references as much as possible, avoid Variant and Object types
  • Avoid implicitly working off the active sheet; use explicit worksheet references whenever possible
\$\endgroup\$

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.