Hi,
Thanks for the reply,
I don't get an error, the code misses out .zip files.
The code creates a list of all the files on a disk, however it no longer adds zip files to the list.
See my code below.
Sub Srch()
Dim i As Long, z As Long, ws As Worksheet
Dim fLdr As String
Dim Title As String
Dim TDate As Date
Dim Expire As Date
Application.ScreenUpdating = False
TDate = Int(Now())
Expire = "30/06/2007"
If TDate >= Expire Then
MsgBox ("This application has expired contact
naill_mclean@hotmail.com for a new License")
Exit Sub
End If
Title = InputBox("Enter Sheet Heading ")
fLdr = InputBox("Enter Drive e.g 'D:\' or leave blank for folder selection box")
If fLdr = "" Then
fLdr = BrowseForFolderShell
Else
End If
With Application.FileSearch
.NewSearch
.LookIn = fLdr
.FileType = msoFileTypeAllFiles
.SearchSubFolders = True
.Filename = "*.*"
Set ws = ThisWorkbook.Worksheets.Add(Sheets(1))
On Error GoTo 1
2: ws.Name = "filesearch results"
On Error GoTo 0
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
If Left$(.FoundFiles(i), 1) = Left$(fLdr, 1) Then
If CBool(Len(Dir(.FoundFiles(i)))) Then
z = z + 1
ws.Cells(z + 1, 1).Resize(, 1) = _
Array(Dir(.FoundFiles(i)))
ws.Cells(z + 1, 2) = .FoundFiles(i)
ws.Hyperlinks.Add anchor:=Cells(z + 1, 1), _
Address:=.FoundFiles(i)
End If
End If
Next i
Columns("B:B").Select
Selection.TextToColumns Destination:=Range("B2"), DataType:=xlDelimited, _
TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="\"
End If
End With
Range("A1").Value = "File Name"
Range("B1").Value = "Drive"
Range("C1").Value = "First Folder"
Range("D1").Value = "Second Folder"
Rows("1:1").Select
Cells.EntireColumn.AutoFit
With ActiveSheet.PageSetup
.CenterHeader = "&30" & Title
.LeftMargin = Application.InchesToPoints(0.01)
.RightMargin = Application.InchesToPoints(0.01)
.TopMargin = Application.InchesToPoints(0.6)
.BottomMargin = Application.InchesToPoints(0.01)
.HeaderMargin = Application.InchesToPoints(0.01)
.FooterMargin = Application.InchesToPoints(0.01)
.PrintHeadings = False
.PrintGridlines = True
.PrintComments = xlPrintNoComments
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = True
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 10
.PrintErrors = xlPrintErrorsDisplayed
End With
ActiveWindow.Zoom = 85
Application.ScreenUpdating = True
Rows("1:1").Select
Selection.AutoFilter
Exit Sub
1: Application.DisplayAlerts = False
Worksheets("filesearch results").Delete
Application.DisplayAlerts = True
GoTo 2
End Sub
Function BrowseForFolderShell() As String
Dim objShell As Object, objFolder As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, _
"Please select a Folder", 0, "")
If (Not objFolder Is Nothing) Then
On Error Resume Next
If IsError(objFolder.Items.Item.Path) Then BrowseForFolderShell = _
CStr(objFolder): GoTo Here
On Error GoTo 0
If Len(objFolder.Items.Item.Path) > 3 Then
BrowseForFolderShell = objFolder.Items.Item.Path & _
Application.PathSeparator
Else
browesforfoldershell = objFolder.Items.Item.Path
End If
Else: Application.ScreenUpdating = True: End
End If
Here:
Set objFolder = Nothing: Set objShell = Nothing
End Function
