Is it possible to get a directory listing of filenames using a VBA macro?
I know there are add-ins which you can buy to do this .... but has anyone
done it just with macros?
Nigel
Is it possible to get a directory listing of filenames using a VBA macro?
I know there are add-ins which you can buy to do this .... but has anyone
done it just with macros?
Nigel
Nigel,
Not quite sure what you are after, but
maybe this ...
http://makeashorterlink.com/?Y49E21ECA
Jim Cone
San Francisco, USA
"Nigel Chapman" <[email protected]> wrote in message
news:[email protected]...
> Is it possible to get a directory listing of filenames using a VBA macro?
> I know there are add-ins which you can buy to do this .... but has anyone
> done it just with macros?
>
> Nigel
Yes, this code creates a new worksheet with directories, indents, and
hyperlinks to the files. Just set sFolder to your start point
Option Explicit
Private cnt As Long
Private arfiles
Private level As Long
Sub Folders()
Dim i As Long
Dim sFolder As String
Dim iStart As Long
Dim iEnd As Long
Dim fOutline As Boolean
arfiles = Array()
cnt = -1
level = 1
sFolder = "E:\"
ReDim arfiles(2, 0)
If sFolder <> "" Then
SelectFiles sFolder
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Files").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Worksheets.Add.Name = "Files"
With ActiveSheet
For i = LBound(arfiles, 2) To UBound(arfiles, 2)
If arfiles(0, i) = "" Then
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If
With .Cells(i + 1, arfiles(2, i))
.Value = arfiles(1, i)
.Font.Bold = True
End With
iStart = i + 1
iEnd = iStart
fOutline = False
Else
.Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(2, i)), _
Address:=arfiles(0, i), _
TextToDisplay:=arfiles(1, i)
iEnd = iEnd + 1
fOutline = True
End If
Next
.Columns("A:Z").ColumnWidth = 5
End With
End If
'just in case there is another set to group
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If
Columns("A:Z").ColumnWidth = 5
ActiveSheet.Outline.ShowLevels RowLevels:=1
ActiveWindow.DisplayGridlines = False
End Sub
'-----------------------------------------------------------------------
Sub SelectFiles(Optional sPath As String)
'-----------------------------------------------------------------------
Static FSO As Object
Dim oSubFolder As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim arPath
If FSO Is Nothing Then
Set FSO = CreateObject("SCripting.FileSystemObject")
End If
If sPath = "" Then
sPath = CurDir
End If
arPath = Split(sPath, "\")
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = ""
arfiles(1, cnt) = arPath(level - 1)
arfiles(2, cnt) = level
Set oFolder = FSO.GetFolder(sPath)
Set oFiles = oFolder.Files
For Each oFile In oFiles
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = oFolder.Path & "\" & oFile.Name
arfiles(1, cnt) = oFile.Name
arfiles(2, cnt) = level + 1
Next oFile
level = level + 1
For Each oSubFolder In oFolder.Subfolders
SelectFiles oSubFolder.Path
Next
level = level - 1
End Sub
#If VBA6 Then
#Else
'-----------------------------------------------------------------
Function Split(sText As String, _
Optional sDelim As String = " ") As Variant
'-----------------------------------------------------------------
Dim i%, sFml$, v0, v1
Const sDQ$ = """"
If sDelim = vbNullChar Then
sDelim = Chr(7)
sText = Replace(sText, vbNullChar, sDelim)
End If
sFml = "{""" & Application.Substitute(sText, sDelim, """,""") & """}"
v1 = Evaluate(sFml)
'Return 0 based for compatibility
ReDim v0(0 To UBound(v1) - 1)
For i = 0 To UBound(v0): v0(i) = v1(i + 1): Next
Split = v0
End Function
'---------------------------------------------------------------------------
Public Function InStrRev(stringcheck As String, _
ByVal stringmatch As String, _
Optional ByVal start As Long = -1)
'---------------------------------------------------------------------------
Dim iStart As Long
Dim iLen As Long
Dim i As Long
If iStart = -1 Then
iStart = Len(stringcheck)
Else
iStart = start
End If
iLen = Len(stringmatch)
For i = iStart To 1 Step -1
If Mid(stringcheck, i, iLen) = stringmatch Then
InStrRev = i
Exit Function
End If
Next i
InStrRev = 0
End Function
'-----------------------------------------------------------------
#End If
--
HTH
RP
(remove nothere from the email address if mailing direct)
"Nigel Chapman" <[email protected]> wrote in message
news:[email protected]...
> Is it possible to get a directory listing of filenames using a VBA macro?
> I know there are add-ins which you can buy to do this .... but has anyone
> done it just with macros?
>
> Nigel
>
>
Just paste that in as a new macro, someone else gave me it a while ago on here. just put in the folder name, and select either true or false for the searchsubfolders bit. Also need a \ on the end of the folder name.
Sub GetFileNames()
Do Until MsgBox("Get file names from folder?", vbYesNo) = vbNo
MsgBox "Make sure directory is correct in the macro and click OK."
Dim i As Long
With Application.FileSearch
.NewSearch
.LookIn = "c:\folder_name_here\"
.SearchSubFolders = False
.FileType = msoFileTypeAllFiles
If .Execute > 1 Then
For i = 1 To .FoundFiles.Count
ActiveSheet.Cells(Rows.Count, 1). _
End(xlUp).Offset(1, 0) = .FoundFiles(i)
Next i
End If
There are currently 1 users browsing this thread. (0 members and 1 guests)
Bookmarks