Directory List

[wwbwb]

I'm not sure where to begin or what to search for. Here is what I'm looking for...

I would like a macro, that when activated, would search a given directory, ie. c:\sounds\music\, and list the file names in column A and file types in column B. It would start inputing the information in a5. Every time the macro is run, it should be able to clear row 5 and down, search the given directory and list the information.

Idealy, I would also like the file name to be a link to the file itself if possible.

Anyone know how to do this or what I should be looking for?

Thanks.

 

[jimboy]

I copied this code from this site (see web addess in comments) and have amended it. Not sure you need all of it, but copy it to a new module to be on the safe side.
You need to run the GetFile macro;

'http://www.mrexcel.com/board2/viewtopic.php?t=60925&highlight=list+files+drive
Public RetVal As Variant
'
Function GetOption(OpArray, Default, Title)
Dim TempForm
Dim X As Integer, i As Integer, TopPos As Integer
Dim MaxWidth As Long
Set TempForm = ThisWorkbook.VBProject.VBComponents.Add(3)
TempForm.Properties("Width") = 800
TopPos = 4
MaxWidth = 0
For i = LBound(OpArray) To UBound(OpArray)
Set NewOptionButton = TempForm.Designer.Controls.Add("forms.OptionButton.1")
With NewOptionButton
.Width = 800
.Caption = OpArray(i)
.Height = 15
.Left = 8
.Top = TopPos
.AutoSize = True
If Default = i Then .Value = True
If .Width > MaxWidth Then MaxWidth = .Width
End With
TopPos = TopPos + 15
Next i
Set NewOptionButton = TempForm.Designer.Controls.Add("forms.OptionButton.1")
With NewOptionButton
.Width = 800
.Caption = "BLANK TEMPLATE"
.Height = 15
.Left = 8
.Top = TopPos
.AutoSize = True
If .Width > MaxWidth Then MaxWidth = .Width
End With
TopPos = TopPos + 15
Set NewCommandButton1 = TempForm.Designer.Controls.Add("forms.CommandButton.1")
With NewCommandButton1
.Caption = "Cancel"
.Height = 18
.Width = 80
.Left = MaxWidth + 12
End With
Set NewCommandButton2 = TempForm.Designer.Controls.Add("forms.CommandButton.1")
With NewCommandButton2
.Caption = "OK"
.Height = 18
.Width = 80
.Left = MaxWidth + 12
End With
With TempForm.CodeModule
X = .CountOfLines
.InsertLines X + 1, "Sub CommandButton1_Click()"
.InsertLines X + 2, "Unload Me"
.InsertLines X + 3, "End Sub"
.InsertLines X + 4, "Sub CommandButton2_Click()"
.InsertLines X + 5, "Dim ctl"
.InsertLines X + 6, "For Each ctl In Me.Controls"
.InsertLines X + 7, "If TypeName(ctl)=""OptionButton"" Then If ctl Then RetVal = ctl.Caption"
.InsertLines X + 8, "Next ctl"
.InsertLines X + 9, "Unload Me"
.InsertLines X + 10, "End Sub"
End With
With TempForm
.Properties("Caption") = Title
.Properties("Width") = NewCommandButton1.Left + NewCommandButton1.Width + 10
If .Properties("Width") < 200 Then
.Properties("Width") = 300
NewCommandButton1.Left = 106
NewCommandButton2.Left = 106
End If
.Properties("Height") = TopPos + 24
NewCommandButton1.Top = TopPos - 15
NewCommandButton2.Top = NewCommandButton1.Top - NewCommandButton1.Height - 5
End With
VBA.UserForms.Add(TempForm.Name).Show
ThisWorkbook.VBProject.VBComponents.Remove VBComponent:=TempForm
GetOption = RetVal
End Function
'
Sub Macro5()
'
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
        "\\ukxxlon01fs0004\users\SteveNash\EXCEL\AFC 2003.xls", TextToDisplay:= _
        "AFC 2003.xls"
End Sub

Sub GetFile()
'http://www.mrexcel.com/board2/viewtopic.php?t=60925&highlight=list+files+drive
Dim i As Integer
Dim Ops() As String
Dim UserChoice As Variant
Dim MyPath As String, MyTempPath As String, MyTempFile As String, mycount As Integer

Dim objShell As Object
Dim objFolder As Object
Dim strFolderFullPath As String
Columns(1).ClearContents
mycount = 5
Set objShell = CreateObject("Shell.Application")
'oFolder = Shell.BrowseForFolder(Hwnd, sTitle, iOptions [, vRootFolder])
Set objFolder = objShell.BrowseForFolder(0, "Please select a folder", 0, "C:\MyFolders\TestFolder")

If (Not objFolder Is Nothing) Then
    '// NB: If SpecFolder= 0 = Desktop then ....
    On Error Resume Next
    If IsError(objFolder.Items.Item.Path) Then strFolderFullPath = CStr(objFolder): GoTo Here
    On Error GoTo 0
    '// Is it the Root Dir?...if so change
    If Len(objFolder.Items.Item.Path) > 3 Then
        strFolderFullPath = objFolder.Items.Item.Path & Application.PathSeparator
    Else
        strFolderFullPath = objFolder.Items.Item.Path
    End If
Else
    MsgBox "User cancelled": End
End If

Here:
MsgBox "You selected:= " & strFolderFullPath, vbInformation, "ObjectFolder:= " & objFolder
'MyPath = "G:\Accounts"
MyPath = strFolderFullPath
'MyTempPath = "G:\"
'MyTempFile = "Book5.xls"
MyFile = Dir(MyPath & Application.PathSeparator & _
"*.*", vbDirectory)
Do While MyFile <> ""
If MyFile = ThisWorkbook.Name Then GoTo ResumeSub:
ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & mycount), Address:= _
        strFolderFullPath & MyFile, TextToDisplay:=MyFile

'Range("A" & mycount).Value = MyFile
mycount = mycount + 1
i = i + 1
'ReDim Preserve Ops(1 To i)
'Ops(i) = MyFile
ResumeSub:
MyFile = Dir
Loop
'UserChoice = GetOption(Ops, 1, "Select one of the files !")
'If UserChoice = False Then Exit Sub
'If UserChoice = "BLANK TEMPLATE" Then
'MyPath = MyTempPath
'UserChoice = MyTempFile
'End If
'Workbooks.Open MyPath & Application.PathSeparator & UserChoice
End Sub
Sub Macro1()
    Range("B2:N" & Range("N65536").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Range("Q65536").End(xlUp).Offset(1, 0)
    
End Sub


Sub BrowseForFolderShell()
Dim objShell As Object
Dim objFolder As Object
Dim strFolderFullPath As String

Set objShell = CreateObject("Shell.Application")
'oFolder = Shell.BrowseForFolder(Hwnd, sTitle, iOptions [, vRootFolder])
Set objFolder = objShell.BrowseForFolder(0, "Please select a folder", 0, "C:\MyFolders\TestFolder")

If (Not objFolder Is Nothing) Then
    '// NB: If SpecFolder= 0 = Desktop then ....
    On Error Resume Next
    If IsError(objFolder.Items.Item.Path) Then strFolderFullPath = CStr(objFolder): GoTo Here
    On Error GoTo 0
    '// Is it the Root Dir?...if so change
    If Len(objFolder.Items.Item.Path) > 3 Then
        strFolderFullPath = objFolder.Items.Item.Path & Application.PathSeparator
    Else
        strFolderFullPath = objFolder.Items.Item.Path
    End If
Else
    MsgBox "User cancelled": End
End If

Here:
MsgBox "You selected:= " & strFolderFullPath, vbInformation, "ObjectFolder:= " & objFolder

Set objFolder = Nothing
Set objShell = Nothing

End Sub

 

[tusharm]

Check out the Directory List add-in available from the Excel/Add-Ins/'Directory List' page of my web site.

I'm not sure where to begin or what to search for. Here is what I'm looking for...

I would like a macro, that when activated, would search a given directory, ie. c:\sounds\music\, and list the file names in column A and file types in column B. It would start inputing the information in a5. Every time the macro is run, it should be able to clear row 5 and down, search the given directory and list the information.

Idealy, I would also like the file name to be a link to the file itself if possible.

Anyone know how to do this or what I should be looking for?

Thanks.

 

[wwbwb]

jimboy: I put in the code and keep getting an error message. "ActiveX component can't create object."


tusharm: I installed the add-in and keep getting an error message. "The macro 'dicrectory.xla!startADir' cannot be found."

 

[wwbwb]

hindpan.y6x0w;

 

[wwbwb]

Found this on http://www.mrexcel.com/board2/viewtopic.php?t=70602&highlight=list+files+folder

Sub ListFiles() 
    Dim fileList() As String 
    Dim fName As String 
    Dim fPath As String 
    Dim I As Integer 
    
    fPath = "C:\My Documents\" 
    fName = Dir(fPath & "*.xls") 
    While fName <> "" 
        I = I + 1 
        ReDim Preserve fileList(1 To I) 
        fileList(I) = fName 
        fName = Dir() 
    Wend 
    If I = 0 Then 
        MsgBox "No files found" 
        Exit Sub 
    End If 
     For I = 1 To UBound(fileList) 
        Range("A" & I).Value = fileList(I) 
     Next 
    End Sub

how can I edit this so that it begins adding on a5 and removes the file ext in col a and puts the file ext in col b?

 

[jimboy]

Try this, but my other code is better

Sub ListFiles()
    Dim fileList() As String
    Dim fName As String
    Dim fPath As String
    Dim I As Integer
    Dim myfind As Integer, mylen As Integer, mynum As Integer
    fPath = "C:\"
    fName = Dir(fPath & "*.xls")
    While fName <> ""
        I = I + 1
        ReDim Preserve fileList(1 To I)
        fileList(I) = fName
        fName = Dir()
    Wend
    If I = 0 Then
        MsgBox "No files found"
        Exit Sub
    End If
     For I = 1 To UBound(fileList)
     myfind = WorksheetFunction.Find(".", fileList(I), 1) - 1
     mylen = Len(fileList(I))
     mynum = mylen - myfind
        Range("A" & I + 4).Value = Left(fileList(I), myfind)
        Range("B" & I + 4).Value = Right(fileList(I), mynum)
     Next
    End Sub

 

[wwbwb]

Try this, but my other code is better

Thanks. The last code works beautifully. As for your other code, each time I try to run it, I keep getting this error message. "ActiveX component can't create object"