Need help please! List Folders & Subfolders From Directory:

[pedie]

Hi Everone:

The code below is given me error, Run time error '70':
Permission Denied.
I'm using 2007 excel, in my personal computer where this is not password protected. And as intructed i have done the setting where one requires a reference to the "Microsoft Scripting Library". In the VBE I choose Tools/References and clicked "Microsoft Scripting Runtime".


This is happening when i run the code below
with Sub CreateList() heading specifically.
when i run
Sub CreateList()
it is not giving any error;

Am I doing something wrong that I am getting this error???

I am looking for list of folders with size particulary

Thanks for helping.

Pedie.



Code:
resource:
http://www.ozgrid.com/forum/showthread.php?t=69086

Const BIF_RETURNONLYFSDIRS As Long = &H1 ''' For finding a folder to start document searching
Const BIF_DONTGOBELOWDOMAIN As Long = &H2 ''' Does not include network folders below the domain level in the tree view control
Const BIF_RETURNFSANCESTORS As Long = &H8 ''' Returns only file system ancestors.
Const BIF_BROWSEFORCOMPUTER As Long = &H1000 ''' Returns only computers.
Const BIF_BROWSEFORPRINTER As Long = &H2000 ''' Returns only printers.
Const BIF_BROWSEINCLUDEFILES As Long = &H4000 ''' Returns everything.

Const MAX_PATH As Long = 260

Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszINSTRUCTIONS As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Declare Function SHGetPathFromIDListA Lib "shell32.dll" (ByVal pidl As Long, ByVal pszBuffer As String) As Long
Declare Function SHBrowseForFolderA Lib "shell32.dll" (lpBrowseInfo As BROWSEINFO) As Long


Function BrowseFolder() As String

Const szINSTRUCTIONS As String = "Choose the folder to use for this operation." & vbNullChar

Dim uBrowseInfo As BROWSEINFO
Dim szBuffer As String
Dim lID As Long
Dim lRet As Long

With uBrowseInfo
.hOwner = 0
.pidlRoot = 0
.pszDisplayName = String$(MAX_PATH, vbNullChar)
.lpszINSTRUCTIONS = szINSTRUCTIONS
.ulFlags = BIF_RETURNONLYFSDIRS
.lpfn = 0
End With

szBuffer = String$(MAX_PATH, vbNullChar)

''' Show the browse dialog.
lID = SHBrowseForFolderA(uBrowseInfo)

If lID Then
''' Retrieve the path string.
lRet = SHGetPathFromIDListA(lID, szBuffer)
If lRet Then BrowseFolder = Left$(szBuffer, InStr(szBuffer, vbNullChar) - 1)
End If

End Function
-------------

Option Explicit

Sub CreateList()
Application.ScreenUpdating = False
Workbooks.Add ' create a new workbook for the folder list
' add headers
With Cells(1, 1)
.Value = "Folder contents:"
.Font.Bold = True
.Font.Size = 12
End With
Cells(3, 1).Value = "Folder Path:"
Cells(3, 2).Value = "Folder Name:"
Cells(3, 3).Value = "Size:"
Cells(3, 4).Value = "Subfolders:"
Cells(3, 5).Value = "Files:"
Cells(3, 6).Value = "Short Name:"
Cells(3, 7).Value = "Short Path:"
Range("A3:G3").Font.Bold = True
ListFolders BrowseFolder, True
Application.ScreenUpdating = True
End Sub

Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the folders in SourceFolder
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim r As Long
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
' display folder properties
r = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(r, 1).Value = SourceFolder.Path
Cells(r, 2).Value = SourceFolder.Name
Cells(r, 3).Value = SourceFolder.Size
Cells(r, 4).Value = SourceFolder.SubFolders.Count
Cells(r, 5).Value = SourceFolder.Files.Count
Cells(r, 6).Value = SourceFolder.ShortName
Cells(r, 7).Value = SourceFolder.ShortPath
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFolders SubFolder.Path, True
Next SubFolder
Set SubFolder = Nothing
End If
Columns("A:G").AutoFit
Set SourceFolder = Nothing
Set FSO = Nothing
ActiveWorkbook.Saved = True

End Sub

----------------------

Sub Ck()

Dim strStartPath As String

strStartPath = "C:\" 'ENTER YOUR START FOLDER HERE
ListFolder strStartPath

End Sub
Sub ListFolder(sFolderPath As String)

Dim FS As New FileSystemObject
Dim FSfolder As Folder
Dim subfolder As Folder
Dim i As Integer

Set FSfolder = FS.GetFolder(sFolderPath)

For Each subfolder In FSfolder.SubFolders
DoEvents
i = i + 1
'added this line
Cells(i, 1) = subfolder
'commented out this one
'Debug.Print subfolder
Next subfolder

Set FSfolder = Nothing

'optional, I suppose
MsgBox "Total sub folders in " & sFolderPath & " : " & i

End Sub

----------------------

Option Explicit

Sub TestListFolders()

Application.ScreenUpdating = False

'create a new workbook for the folder list

'commented out by dr
'Workbooks.Add

'line added by dr to clear old data
Cells.Delete

' add headers
With Range("A1")
.Formula = "Folder contents:"
.Font.Bold = True
.Font.Size = 12
End With

Range("A3").Formula = "Folder Path:"
Range("B3").Formula = "Folder Name:"
Range("C3").Formula = "Size:"
Range("D3").Formula = "Subfolders:"
Range("E3").Formula = "Files:"
Range("F3").Formula = "Short Name:"
Range("G3").Formula = "Short Path:"
Range("A3:G3").Font.Bold = True

'ENTER START FOLDER HERE
' and include subfolders (true/false)
ListFolders "C:\", True

Application.ScreenUpdating = True

End Sub

Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the folders in SourceFolder
' example: ListFolders "C:\", True
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim r As Long

Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)

'line added by dr for repeated "Permission Denied" errors

On Error Resume Next

' display folder properties
r = Range("A65536").End(xlUp).Row + 1
Cells(r, 1).Formula = SourceFolder.Path
Cells(r, 2).Formula = SourceFolder.Name
Cells(r, 3).Formula = SourceFolder.Size
Cells(r, 4).Formula = SourceFolder.SubFolders.Count
Cells(r, 5).Formula = SourceFolder.Files.Count
Cells(r, 6).Formula = SourceFolder.ShortName
Cells(r, 7).Formula = SourceFolder.ShortPath
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFolders SubFolder.Path, True
Next SubFolder
Set SubFolder = Nothing
End If

Columns("A:G").AutoFit

Set SourceFolder = Nothing
Set FSO = Nothing

'commented out by dr
'ActiveWorkbook.Saved = True

End Sub
---------------

 

[pedie]

Any sugestion, advice...help of any kind will greatly appriciated!

 

[pedie]

Thanks everyone for looking in...

I think it is working now:


Thanks alot!

 

[VoG]

I got the same error as you. What did you do to fix it?

When posting code please use code tags:

Type [*code] (without the *)

Paste in the code

Type [*/code] (without the *)

That preserves the indenting and makes the code much easier to read.

Example

No code tags

Sub test2()
Dim LR As Long, i As Long, Found As Range
With Sheets("Y")
Set Found = .Rows(1).Find(what:="Totals", LookIn:=xlValues, lookat:=xlWhole)
If Found Is Nothing Then Exit Sub
LR = Found.Column - 1
For i = 1 To LR
With .Cells(1, i)
If Sheets("1").Cells(1, i) <> .Value Then Sheets("1").Columns(i).Insert
End With
Next i
End With
End Sub

With code tags

Sub test2()
Dim LR As Long, i As Long, Found As Range
With Sheets("Y")
    Set Found = .Rows(1).Find(what:="Totals", LookIn:=xlValues, lookat:=xlWhole)
    If Found Is Nothing Then Exit Sub
    LR = Found.Column - 1
    For i = 1 To LR
        With .Cells(1, i)
            If Sheets("1").Cells(1, i) <> .Value Then Sheets("1").Columns(i).Insert
        End With
    Next i
End With
End Sub

 

[pedie]

I got the same error as you. What did you do to fix it?

When posting code please use code tags:

Type [*code] (without the *)

Paste in the code

Type [*/code] (without the *)

/QUOTE]

Vog! thank you for advising me how to insert code in the right way....
Well bout the thing that made it work...I didnt do anything special just did the settings as advised, tools > ref > ms scripting runtime (checked the box).
And it doesnt give error message any more.
Pedie!