grayderek
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
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.
ASKER
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.
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.
ASKER
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
(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
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
The dialogue between two members help to solve the problem. The change in attribute numbers between MS operating systems should be broadcast more widely.
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.