Jumparound
New Member
- Joined
- Aug 4, 2015
- Messages
- 45
- Office Version
- 2016
- Platform
- Windows
Hi,
We've got a fairly complex file structure and I would like to create an index for it in Excel. I've played about with getting the information out of DOS but it's quite messy and I wonder if VBA could be used to speed up the process. I found the below code online which seems to work quite well (I'm not able to write my own, too dumb). However it only takes the info from my documents and I would like to specify another drive. I can't see where in the code it is getting the instruction for where to pull the information from. Can anyone help?
I also wondered secondly if there was a simple way to make the files links too in VBA? Might not be a straightforward task and not as important.
Thank you!
We've got a fairly complex file structure and I would like to create an index for it in Excel. I've played about with getting the information out of DOS but it's quite messy and I wonder if VBA could be used to speed up the process. I found the below code online which seems to work quite well (I'm not able to write my own, too dumb). However it only takes the info from my documents and I would like to specify another drive. I can't see where in the code it is getting the instruction for where to pull the information from. Can anyone help?
I also wondered secondly if there was a simple way to make the files links too in VBA? Might not be a straightforward task and not as important.
Code:
Option Explicit
Const ShowLevels As Integer = 2
Public Sub showAll()
If ActiveSheet.UsedRange.Rows.Count > 1 Then ActiveSheet.Range("2:" & ActiveSheet.UsedRange.Rows.Count).Delete
Application.ScreenUpdating = False
Range("A1").Activate
showDirs ActiveCell.Value, ShowLevels
Application.ScreenUpdating = True
ActiveSheet.Outline.ShowLevels RowLevels:=2 ' show 1st level subfolders and files
End Sub
Private Sub showDirs(pm_Path As String, pm_Level As Integer)
Dim sDirEntry, arrDirEntries(), maxd
maxd = -1
ActiveCell.Offset(1, 1).Activate
Dim savecell: Set savecell = ActiveCell
On Error Resume Next
sDirEntry = Dir(pm_Path, vbDirectory Or vbNormal Or vbHidden)
If Err.Number <> 0 Then GoTo oops ' oops1
While sDirEntry <> ""
If sDirEntry <> "." And sDirEntry <> ".." Then
maxd = maxd + 1
ReDim Preserve arrDirEntries(maxd)
arrDirEntries(maxd) = sDirEntry
End If
sDirEntry = Dir()
If Err.Number <> 0 Then GoTo oops ' oops2
Wend
If maxd = -1 Then
' empty
Else
Dim at
For maxd = 0 To UBound(arrDirEntries)
at = GetAttr(pm_Path & arrDirEntries(maxd)) And 31 ' not interested in archive (32) and higher, encrypted/compressed
If (at And vbHidden) = vbHidden Then ActiveCell.Font.Italic = True
'If (at And vbAlias) = vbAlias Then ActiveCell.Font.Color = vbGreen
'If (at And vbReadOnly) = vbReadOnly Then ' ...
If (at And vbDirectory) = vbDirectory Then
ActiveCell.Value = arrDirEntries(maxd)
ActiveCell.Font.Bold = True
If pm_Level > 0 Then
showDirs pm_Path & arrDirEntries(maxd) & "\", pm_Level - 1
ActiveCell.Offset(0, -1).Activate
Else
ActiveCell.Offset(1, 0).Activate
End If
End If
Next
For maxd = 0 To UBound(arrDirEntries)
at = GetAttr(pm_Path & arrDirEntries(maxd)) And 31
If (at And vbHidden) = vbHidden Then ActiveCell.Font.Italic = True
If (at And vbDirectory) = 0 Then
ActiveCell.Value = arrDirEntries(maxd)
ActiveCell.Offset(1, 0).Activate
End If
Next
Range(savecell, ActiveCell.Offset(-1, 0)).Rows.Group
End If
GoTo done
oops:
ActiveCell.Offset(-1, -1).Font.Color = vbRed ' access denied
done:
Set savecell = Nothing
End Sub
Thank you!