Link to home
Start Free TrialLog in
Avatar of grayderek
grayderekFlag for United Kingdom of Great Britain and Northern Ireland

asked on

VBscript in excel 2003 does not work in office 2010 - help with conversion

I have vb script in an excel spreadsheet attached (thanks to EE) which populates a spreadsheet with a list of file names and specified properties from a selected directory- works perfectly.  Just upgraded to office 2010 and although this script runs, does not return the file properties. Can someone either amend the script or post a file with amended script populatefromfolders.xls
Public X()
Public i As Long
Public objShell, objFolder, objFolderItem
Public FSO, oFolder, Fil
 
Sub MainExtractData()
     
    Dim NewSht As Worksheet
    Dim MainFolderName As String
    Dim TimeLimit As Long, StartTime As Double
     
    Dim X(1 To 65536, 1 To 11)
     
    Set objShell = CreateObject("Shell.Application")
    TimeLimit = Application.InputBox("Please enter the maximum time that you wish this code to run for in minutes" & vbNewLine & vbNewLine & _
    "Leave this at zero for unlimited runtime", "Time Check box", 0)
    StartTime = Timer
     
    Application.ScreenUpdating = False
    MainFolderName = BrowseForFolder()
    Set NewSht = ThisWorkbook.Sheets.Add
    
     
    X(1, 1) = "Path"
    X(1, 2) = "File Name"
    X(1, 3) = "Last Accessed"
    X(1, 4) = "Last Modified"
    X(1, 5) = "Created"
    X(1, 6) = "Type"
    X(1, 7) = "Size"
    X(1, 8) = "Subject"
    X(1, 9) = "Author"
    X(1, 10) = "Owner"
    X(1, 11) = "title"
     
    i = 1
     
    Set FSO = CreateObject("scripting.FileSystemObject")
    Set oFolder = FSO.GetFolder(MainFolderName)
     'error handling to stop the obscure error that occurs at time when retrieving DateLastAccessed
    On Error Resume Next
    For Each Fil In oFolder.Files
        Set objFolder = objShell.Namespace(oFolder.Path)
        Set objFolderItem = objFolder.ParseName(Fil.Name)
        i = i + 1
        If i Mod 20 = 0 And TimeLimit <> 0 And Timer > (TimeLimit * 60 + StartTime) Then
            GoTo FastExit
        End If
        If i Mod 50 = 0 Then
            Application.StatusBar = "Processing File " & i
            DoEvents
        End If
        X(i, 1) = oFolder.Path
        X(i, 2) = Fil.Name
        X(i, 3) = Fil.DateLastAccessed
        X(i, 4) = Fil.DateLastModified
        X(i, 5) = Fil.DateCreated
        X(i, 6) = Fil.Type
        X(i, 7) = Fil.Size
        X(i, 8) = objFolder.GetDetailsOf(objFolderItem, 11)
        X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
        X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 8)
        X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 10)
    Next
     
     'Get subdirectories if needed
    If TimeLimit = 0 Then
        Call RecursiveFolder(oFolder, 0)
    Else
        If Timer < (TimeLimit * 60 + StartTime) Then Call RecursiveFolder(oFolder, TimeLimit * 60 + StartTime)
    End If
     
FastExit:
    Range("A:K") = X
    If i < 65535 Then Range(Cells(i + 1, "A"), Cells(65536, "A")).EntireRow.Delete
    Range("A:K").WrapText = False
    Range("A:K").EntireColumn.AutoFit
    Range("1:1").Font.Bold = True
    Rows("2:2").Select
    ActiveWindow.FreezePanes = True
    Range("a1").Activate
     
    Set FSO = Nothing
    Set objShell = Nothing
    Set oFolder = Nothing
    Set objFolder = Nothing
    Set objFolderItem = Nothing
    Set Fil = Nothing
    Application.StatusBar = ""
    Application.ScreenUpdating = True
End Sub
 
Sub RecursiveFolder(xFolder, TimeTest As Long)
    Dim SubFld
    For Each SubFld In xFolder.SubFolders
        Set oFolder = FSO.GetFolder(SubFld)
        Set objFolder = objShell.Namespace(SubFld.Path)
        For Each Fil In SubFld.Files
            Set objFolder = objShell.Namespace(oFolder.Path)
             'Problem with objFolder at times
            If Not objFolder Is Nothing Then
                Set objFolderItem = objFolder.ParseName(Fil.Name)
                i = i + 1
                If i Mod 20 = 0 And TimeTest <> 0 And Timer > TimeTest Then
                    Exit Sub
                End If
                If i Mod 50 = 0 Then
                    Application.StatusBar = "Processing File " & i
                    DoEvents
                End If
                X(i, 1) = SubFld.Path
                X(i, 2) = Fil.Name
                X(i, 3) = Fil.DateLastAccessed
                X(i, 4) = Fil.DateLastModified
                X(i, 5) = Fil.DateCreated
                X(i, 6) = Fil.Type
                X(i, 7) = Fil.Size
                X(i, 8) = objFolder.GetDetailsOf(objFolderItem, 11)
                X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
                X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 8)
                X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 30)
            Else
                Debug.Print Fil.Path & " " & Fil.Name
            End If
        Next
        Call RecursiveFolder(SubFld, TimeTest)
    Next
End Sub
 
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
     'Function purpose:  To Browser for a user selected folder.
     'If the "OpenAt" path is provided, open the browser at that directory
     'NOTE:  If invalid, it will open at the Desktop level
     
    Dim ShellApp As Object
     
     'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
     
     'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
     
     'Destroy the Shell Application
    Set ShellApp = Nothing
     
     'Check for invalid or non-entries and send to the Invalid error
     'handler if found
     'Valid selections can begin L: (where L is a letter) or
     '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select
     
    Exit Function
     
Invalid:
     'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
     
End Function

Open in new window

Avatar of Patrick Matthews
Patrick Matthews
Flag of United States of America image

Seems to be working for me in Excel 2010, although I am noticing that it is not recursing through the "child" directories.

You may want to have a look at this:

https://www.experts-exchange.com/questions/25063189/file-listing-in-Excel-VBA-Script.html?anchorAnswerId=26340696#a26340696

It provides the option to drill through the child directories, if desired.
Avatar of grayderek

ASKER

matthewspatrick:  The code sugestted works as does mine however I need to return the title, subject, author etc can you provide the additional code please.
Just graft in the code from your that already grabs those attributes.
matthewspatrick:  This is where my problem is, the original code does not return the correct property information for 'title', 'subject' 'author' etc.  
The code you directed me too does not have these properties - I have tried grafting my code but my skills not good I just get object not specified etc. (this is why I come here :),

With my posted code I get all items from line 53 to 59; the info returned for lines 60-63 is incorrect.  Could someone either provide amendments to my code or additions to the one linked please.
Your code is returning those attributes for me where the files actually have the attributes populated.  However, not every file will actually have the attributes populated.  If the file attributes aren't populated, then no code is going to be able to pull them.
matthewspatrick: My code works in Windows xp with office 2003 environment, but as said it does not work for the properties stated since upgrading to windows 7 and office 2010.
(I am aware that no data can returned when no properties populated :)
Are you testing my code on a windows 7 with office 2010?
If this helps; Having checked the vb references on both pc's they are the same except  2003 has MS object libraries 11 listed and 2010 pc has 2003 has MS object libraries 14
SOLUTION
Avatar of Patrick Matthews
Patrick Matthews
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
ASKER CERTIFIED SOLUTION
Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
The dialogue between two members help to solve the problem.  The change in attribute numbers between MS operating systems should be broadcast more widely.