Option Explicit

Sub dirtosheet()
'Subject: Re: i 'm stuck, literally
'From: "Tom Ogilvy" <ogilvtw2@hqda.army.mil>
'Date: Wed, 7 Jul 1999 14:57:56 -0400>
'  Aug 8, 1999 http://groups.google.com/groups?oi=djq&selm=an_379201225
'Newsgroups: microsoft.public.Excel.misc
Dim path, filename, pathstr

Dim i As Long    'DIM added
Dim rw  As Long

pathstr = "c:\aol40\"    'set default
pathstr = InputBox("supply pathname" & Chr(10) & "  dirtosheet macro" _
  , "path = Dir(""c:\aol40\"")", pathstr)
If Len(pathstr) = 0 Then Exit Sub
path = Dir(pathstr)
filename = path
 i = 1
 Do Until filename = ""
    ActiveCell.Offset(i, 0) = filename
    filename = Dir
    i = i + 1
Loop
ActiveCell.Offset(i, 0) = " "
End Sub
Sub DirectorytoSheet3()
Dim sh As Worksheet
'Set sh = ThisWorkbook.Worksheets("$DirList3")

'------------------
Dim lstAttr As Long      'DIM added
Dim myPath  As Variant
Dim myName  As String
Dim rw      As Long
Dim fattr   As String, StrAttr As String

On Error Resume Next
Set sh = ThisWorkbook.Worksheets("$DirList3")
If Err.Description <> "" Then
    Sheets.Add
    ActiveSheet.Name = "$DirList3"
End If
On Error GoTo 0
Set sh = ThisWorkbook.Worksheets("$DirList3")
'------------------

lstAttr = vbNormal + vbReadOnly + vbHidden
lstAttr = lstAttr + vbSystem + vbDirectory
lstAttr = lstAttr + vbArchive
myPath = "c:\"  ' Set the path.
myName = Dir(myPath, lstAttr)  ' Retrieve the first entry.
sh.Cells(1, 1) = "Path:"
sh.Cells(1, 2) = myPath
sh.Cells(2, 2) = "Name"
sh.Cells(2, 3) = "Date"
sh.Cells(2, 4) = "Time"
sh.Cells(2, 5) = "Size"
sh.Cells(2, 6) = "Attr"
rw = 3
 
Do While myName <> ""  ' Start the loop.
' Ignore the current directory and
' the encompassing directory.
  If myName <> "." And myName <> ".." Then sh.Cells(rw, 2) = myName
  sh.Cells(rw, 3) = _
  Int(FileDateTime(myPath & myName))
  sh.Cells(rw, 4) = _
  FileDateTime(myPath & myName) - _
  Int(FileDateTime(myPath & myName))
  sh.Cells(rw, 5) = _
  FileLen(myPath & myName)
  fattr = GetAttr(myPath & myName)
  StrAttr = ""
  If fattr <> vbNormal Then  '(vbNormal = 0 )
    If (fattr And vbReadOnly) Then
      StrAttr = StrAttr & "R"
    End If
    If (fattr And vbHidden) Then
      StrAttr = StrAttr & "H"
    End If
    If (fattr And vbSystem) Then
      StrAttr = StrAttr & "S"
    End If
    If (fattr And vbDirectory) Then
      StrAttr = StrAttr & "D"
    End If
    If (fattr And vbArchive) Then
      StrAttr = StrAttr & "A"
    End If
  End If
  sh.Cells(rw, 6) = StrAttr
  rw = rw + 1
' End If
  myName = Dir    ' Get next entry.
Loop
Intersect(sh.Range("A1").CurrentRegion, _
sh.Columns("C:C")).Offset(2, 0).NumberFormat = _
"mm/dd/yy"
Intersect(sh.Range("A1").CurrentRegion, _
sh.Columns("D:D")).Offset(2, 0).NumberFormat = _
"h:mm AM/PM"
End Sub
 
Sub DirectorytoSheet()
'From: "Thomas Ogilvy" <twogilvy@email.msn.com>
'Subject: Re: Help - Read a Disk Directory to into a Speadsheet?
'Date: 08 Aug 1998 00:00:00 GMT
'Newsgroups: microsoft.public.Excel.programming
Dim sh As Worksheet

Dim lstAttr As Long      'DIM added
Dim myPath As Variant
Dim myName As String
Dim rw     As Long
Dim fattr As String, StrAttr As String

'add $DirList if not already present
On Error Resume Next
Set sh = ThisWorkbook.Worksheets("$DirList")
If Err.Description <> "" Then
    Sheets("$DirList").Add
End If
On Error GoTo 0
Set sh = ThisWorkbook.Worksheets("$DirList")

lstAttr = vbNormal + vbReadOnly + vbHidden
lstAttr = lstAttr + vbSystem + vbDirectory
lstAttr = lstAttr + vbArchive

myPath = InputBox("Supply path, must end with backslash" _
       & Chr(10) & "  DirectorytoSheet macro to $DirList", _
     "Supply Pathname -- Single directory", "c:\aol40\")
If Len(myPath) = 0 Then Exit Sub

myName = Dir(myPath, lstAttr)  ' Retrieve the first entry.
sh.Cells(1, 1) = "Path:"
sh.Cells(1, 2) = myPath
sh.Cells(2, 2) = "Name"
sh.Cells(2, 3) = "Date"
sh.Cells(2, 4) = "Time"
sh.Cells(2, 5) = "Size"
sh.Cells(2, 6) = "Attr"
sh.Cells(1, 6) = Now()
rw = 3

Do While myName <> ""   ' Start the loop.
 ' Ignore the current directory and
 ' the encompassing directory.
 If myName <> "." And myName <> ".." Then
  sh.Cells(rw, 2) = myName
  sh.Cells(rw, 3) = _
  Int(FileDateTime(myPath & myName))
  sh.Cells(rw, 4) = _
  FileDateTime(myPath & myName) - _
  Int(FileDateTime(myPath & myName))
  sh.Cells(rw, 5) = _
  FileLen(myPath & myName)
   fattr = GetAttr(myPath & myName)
   StrAttr = ""
   If fattr <> vbNormal Then  '(vbNormal = 0 )
    If (fattr And vbReadOnly) Then
     StrAttr = StrAttr & "R"
    End If
    If (fattr And vbHidden) Then
     StrAttr = StrAttr & "H"
    End If
    If (fattr And vbSystem) Then
     StrAttr = StrAttr & "S"
    End If
    If (fattr And vbDirectory) Then
     StrAttr = StrAttr & "D"
    End If
    If (fattr And vbArchive) Then
     StrAttr = StrAttr & "A"
    End If
   End If
   sh.Cells(rw, 6) = StrAttr
   rw = rw + 1
  End If
  myName = Dir    ' Get next entry.
Loop
  sh.Cells(rw, 1) = "****"
Beep
Intersect(sh.Range("A1").CurrentRegion, _
sh.Columns("C:C")).Offset(2, 0).NumberFormat = _
"mm/dd/yy"
Intersect(sh.Range("A1").CurrentRegion, _
sh.Columns("D:D")).Offset(2, 0).NumberFormat = _
"h:mm AM/PM"
Beep
End Sub

'----------------------------
Function DirSize(s As String) As Double
'    "Dana DeLouis" 
'  References: <D-qdndsYUdud-crcRVn-og@comcast.com>
'  Subject: Re: Function to determine Directory Size
'  Date: Sun, 26 Sep 2004 23:51:51 -0400
'  Message-ID: <uHP$YVEpEHA.3428@TK2MSFTNGP11.phx.gbl>
'      ?DirSize("C:\Documents and Settings\Bob\My Documents\School")
    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    DirSize = fso.GetFolder(s).Size
End Function