CD-ROM - List File Attributes of Directory and Subdirectores (like brettdj's KB)

**sheeeng** · 06-14-2005, 08:22 AM

Hi all, esp to brettdj.

I need your help. Can this KB use to extract file attributes from CD-ROM? I burn the CD using Nero. I want to make a library on what is contain in the CD-ROM.

I try it on CD-ROM but I only get one record each time.

Can I name the worksheet name on Excel according to the CD Name?

Related KB: (Thanks to brettdj!

)
http://www.vbaexpress.com/kb/getarticle.php?kb_id=405

Thanks.

**JKwan** · 06-14-2005, 09:49 AM

Comment out these two lines

X(i, 3) = Fil.DateLastAccessed

I guess with CD ROM - there is no DateLastAccessed

Or try this, added to check the drive type, if CDROM, ignore the DateLastAccess

Public X()
Public i As Long
Public objShell, objFolder, objFolderItem
Public FSO, oFolder, Fil
Public DriveType As String
Function FindDriveType(drvpath)
   Dim FSO, Drive, DrvType
Set FSO = CreateObject("Scripting.FileSystemObject")
   Set Drive = FSO.GetDrive(Left(drvpath, 3))
   Select Case Drive.DriveType
      Case 0: DrvType = "Unknown"
      Case 1: DrvType = "Removable"
      Case 2: DrvType = "Fixed"
      Case 3: DrvType = "Network"
      Case 4: DrvType = "CD-ROM"
      Case 5: DrvType = "RAM Disk"
   End Select
   FindDriveType = DrvType
End Function

Sub MainExtractData()
Dim NewSht As Worksheet
    Dim MainFolderName As String
    Dim TimeLimit As Long, StartTime As Double
ReDim 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) = "Owner"
    X(1, 9) = "Author"
    X(1, 10) = "Title"
    X(1, 11) = "Comments"
i = 1
Set FSO = CreateObject("scripting.FileSystemObject")
    Set oFolder = FSO.GetFolder(MainFolderName)
    DriveType = FindDriveType(oFolder)
     '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
        If DriveType <> "CD-ROM" Then
            X(i, 3) = Fil.DateLastAccessed
        End If
        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, 8)
        X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
        X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
        X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
    Next
'Get subdirectories
    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
                If DriveType <> "CD-ROM" Then
                    X(i, 3) = Fil.DateLastAccessed
                End If
                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, 8)
                X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
                X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
                X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
            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

**brettdj** · 06-14-2005, 06:30 PM

I'm not sure what the issue is here

I tried this on a DVD and it worked fine as is - I'm not sure whether a CD would behave differently

What does your CD file structure look like, is it just files in the root directory?

Cheers

Dave

**sheeeng** · 06-14-2005, 06:53 PM

Originally Posted by brettdj

I'm not sure what the issue is here

I tried this on a DVD and it worked fine as is - I'm not sure whether a CD would behave differently

What does your CD file structure look like, is it just files in the root directory?

My CD that I burned using Nero has multilple nested folders.

eg.

D: -> Folder A, Folder B, Folder C
Folder A -> File_A1, File_A2, Folder D
.....and so on....maybe until 3 or 4 nested folder.

**sheeeng** · 06-14-2005, 07:09 PM

Thanks, JKwan. Your code works. But can we name the new sheet according to the CD Name?

eg.

My Photo 2005 (D:) - as appear in windows.
"Sheet1" changed to "My Photo 2005"

Thanks.

**johnske** · 06-14-2005, 07:40 PM

Originally Posted by sheeeng

My CD that I burned using Nero has multilple nested folders.

eg.

D: -> Folder A, Folder B, Folder C
Folder A -> File_A1, File_A2, Folder D
.....and so on....maybe until 3 or 4 nested folder.

Hi Sheeeng, Dave,

Not sure if we're talking about quite the same thing here, but I use Nero also and a disc burnt using Nero can have a number of "volumes". These multiple volumes come about by starting Nero first and then inserting the disc that you want to burn, I think this effectively closes off the previous burn session and starts a new one, treating what you have almost like it's on a different disc or drive - where-as if you insert the disc first you only end up with a single Volume (i.e. it's then treated as a single session).

HTH,
John

**sheeeng** · 06-14-2005, 10:22 PM

Originally Posted by johnske

Hi Sheeeng, Dave,

Not sure if we're talking about quite the same thing here, but I use Nero also and a disc burnt using Nero can have a number of "volumes". These multiple volumes come about by starting Nero first and then inserting the disc that you want to burn, I think this effectively closes off the previous burn session and starts a new one, treating what you have almost like it's on a different disc or drive - where-as if you insert the disc first you only end up with a single Volume (i.e. it's then treated as a single session).

I have completely closed the disc without multi-session. No problem on burning.

Originally Posted by sheeeng

Thanks, JKwan. Your code works. But can we name the new sheet according to the CD Name?

eg.

My Photo 2005 (D:) - as appear in windows.
"Sheet1" changed to "My Photo 2005"

Thanks.

Does anyone know how to name the new sheet to the cd name?
Thanks.

**sheeeng** · 06-14-2005, 11:11 PM

Hi brettdj. Thanks a lot for the KB. Cute kid you have.

How to you make your KB intro sheet into WHITE background and the button have "assign macro"?
Can you teach me?

I cannot do it in my Excel 2002.

**JKwan** · 06-15-2005, 07:56 AM

Add line in BOLD to the MainExtractData sub

Set NewSht = ThisWorkbook.Sheets.Add
    ActiveSheet.Name = Mid(MainFolderName, 4, Len(MainFolderName) - 3)

**sheeeng** · 06-15-2005, 08:48 AM

Originally Posted by JKwan

Add line in BOLD to the MainExtractData sub
Set NewSht = ThisWorkbook.Sheets.Add
ActiveSheet.Name = Mid(MainFolderName, 4, Len(MainFolderName) - 3)

Thanks, Jkwan. But I get an error msg as below. It refer to your BOLD line on top. What is wrong?

**JKwan** · 06-15-2005, 09:55 AM

The reason you are getting that error - you are using the ROOT of your Drive (did not think about it). If you use a Directory - then you will be ok.

I don't know if this is good or not. Brettdj can probably give a few pointers... I am changing it to.... If you use the ROOT of a drive, use the VOLUME Name as the tab name

Public X()
Public i As Long
Public objShell, objFolder, objFolderItem
Public fso, oFolder, Fil
Public DriveType As String

Function VolumeName(drvpath)
    Dim fso, d
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set d = fso.GetDrive(fso.GetDriveName(fso.GetAbsolutePathName(drvpath)))
    VolumeName = d.VolumeName
    Set fso = Nothing
End Function
Function FindDriveType(drvpath)
    Dim fso, Drive, DrvType
Set fso = CreateObject("Scripting.FileSystemObject")
    Set Drive = fso.GetDrive(Left(drvpath, 3))
    Select Case Drive.DriveType
        Case 0: DrvType = "Unknown"
        Case 1: DrvType = "Removable"
        Case 2: DrvType = "Fixed"
        Case 3: DrvType = "Network"
        Case 4: DrvType = "CD-ROM"
        Case 5: DrvType = "RAM Disk"
    End Select
    FindDriveType = DrvType
    Set fso = Nothing
End Function

Sub MainExtractData()
Dim NewSht As Worksheet
    Dim MainFolderName As String
    Dim TimeLimit As Long, StartTime As Double
ReDim 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
    If Len(MainFolderName) > 3 Then
        ActiveSheet.Name = Mid(MainFolderName, 4, Len(MainFolderName) - 3)
    Else
        ActiveSheet.Name = VolumeName(MainFolderName)
    End If
    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) = "Owner"
    X(1, 9) = "Author"
    X(1, 10) = "Title"
    X(1, 11) = "Comments"
i = 1
Set fso = CreateObject("scripting.FileSystemObject")
    Set oFolder = fso.GetFolder(MainFolderName)
    DriveType = FindDriveType(oFolder)
     '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
        If DriveType <> "CD-ROM" Then
            X(i, 3) = Fil.DateLastAccessed
        End If
        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, 8)
        X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
        X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
        X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
    Next
'Get subdirectories
    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
                If DriveType <> "CD-ROM" Then
                    X(i, 3) = Fil.DateLastAccessed
                End If
                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, 8)
                X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
                X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
                X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
            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

**sheeeng** · 06-15-2005, 07:24 PM

Thanks, Jkwan. I'll test it. Tell you the results later.

**sheeeng** · 06-15-2005, 10:36 PM

Originally Posted by JKwan

The reason you are getting that error - you are using the ROOT of your Drive (did not think about it). If you use a Directory - then you will be ok.

I don't know if this is good or not. Brettdj can probably give a few pointers... I am changing it to.... If you use the ROOT of a drive, use the VOLUME Name as the tab name

Public X()
Public i As Long
Public objShell, objFolder, objFolderItem
Public fso, oFolder, Fil
Public DriveType As String

Function VolumeName(drvpath)
Dim fso, d
Set fso = CreateObject("Scripting.FileSystemObject")
Set d = fso.GetDrive(fso.GetDriveName(fso.GetAbsolutePathName(drvpath)))
VolumeName = d.VolumeName
Set fso = Nothing
End Function

Function FindDriveType(drvpath)
Dim fso, Drive, DrvType
Set fso = CreateObject("Scripting.FileSystemObject")
Set Drive = fso.GetDrive(Left(drvpath, 3))
Select Case Drive.DriveType
Case 0: DrvType = "Unknown"
Case 1: DrvType = "Removable"
Case 2: DrvType = "Fixed"
Case 3: DrvType = "Network"
Case 4: DrvType = "CD-ROM"
Case 5: DrvType = "RAM Disk"
End Select
FindDriveType = DrvType
Set fso = Nothing
End Function
 
Sub MainExtractData()
Dim NewSht As Worksheet
Dim MainFolderName As String
Dim TimeLimit As Long, StartTime As Double
ReDim 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
If Len(MainFolderName) > 3 Then
ActiveSheet.Name = Mid(MainFolderName, 4, Len(MainFolderName) - 3)
Else
ActiveSheet.Name = VolumeName(MainFolderName)
End If
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) = "Owner"
X(1, 9) = "Author"
X(1, 10) = "Title"
X(1, 11) = "Comments"
i = 1
Set fso = CreateObject("scripting.FileSystemObject")
Set oFolder = fso.GetFolder(MainFolderName)
DriveType = FindDriveType(oFolder)
'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
If DriveType <> "CD-ROM" Then
X(i, 3) = Fil.DateLastAccessed
End If
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, 8)
X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
Next
'Get subdirectories
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
If DriveType <> "CD-ROM" Then
X(i, 3) = Fil.DateLastAccessed
End If
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, 8)
X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
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

Thanks!!

I manage to make a record of my library by automate Excel.

Save a lot of trouble.

Thanks a lot.

Can anyone try it on DVD and see whether it works on DVD?

I don't have DVD drive here. I just want to know whether also it can copy the DVD root name to new sheet.

Thanks.

Another marked solved.

**JKwan** · 06-16-2005, 07:24 AM

You are welcomed. Credit should go to Brettdj, he wrote the program!
As to DVD... I think the Function will still return "CD-ROM", despite the fact that it is a DVD. I think it will work.

**sheeeng** · 06-26-2005, 02:46 AM

Hi all,

I had already modify some code in the attached file...
But it can only read file attibutes from CD only...

It cannot read from a folder on hard disk such as My Document...
Error Msg occured for that task.

How went wrong?

Thanks.

**Bob Phillips** · 06-26-2005, 03:15 PM

Originally Posted by sheeeng

I had already modify some code in the attached file...
But it can only read file attibutes from CD only...

It cannot read from a folder on hard disk such as My Document...
Error Msg occured for that task.

The code is designed to work on drives or folders. My Computer is neither, so the BrowseFolder function returns False, and the GetFolder command fails anyway.

**sheeeng** · 06-26-2005, 11:03 PM

Originally Posted by xld

The code is designed to work on drives or folders. My Computer is neither, so the BrowseFolder function returns False, and the GetFolder command fails anyway.

[VBA]ActiveSheet.Name = Mid(MainFolderName, 4, Len(MainFolderName) - 3)[/VBA]

This line above showed errors, could anyone help to correct?

Error mesasge attached below.

**sheeeng** · 09-09-2005, 04:27 AM

I had been gone for so long. Sorry....Many changes in my life recently.
Could anyone help out on this problem?

Thread: CD-ROM - List File Attributes of Directory and Subdirectores (like brettdj's KB)

Thread Tools

Display

CD-ROM - List File Attributes of Directory and Subdirectores (like brettdj's KB)

Error

Solution

Posting Permissions