PDA

View Full Version : [SOLVED] 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 (http://www.vbaexpress.com/forum/member.php?u=32). :hi: 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. :doh: Can I name the worksheet name on Excel according to the CD Name?

Related KB: (Thanks to brettdj! :thumb )
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
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 (http://www.vbaexpress.com/forum/member.php?u=526). 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
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
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.




Thanks, JKwan (http://www.vbaexpress.com/forum/member.php?u=526). 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
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? :banghead:

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
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!! :hi:

I manage to make a record of my library by automate Excel. :thumb
Save a lot of trouble.

Thanks a lot.

Can anyone try it on DVD and see whether it works on DVD? :doh: 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.
:rotlaugh: Another marked solved. :thumb

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
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
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.

ActiveSheet.Name = Mid(MainFolderName, 4, Len(MainFolderName) - 3)

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?