Application.FileSearch Help

[DLS]

Hi all, I am having a hard time converting this code to another format.

Public Function get_names(fpath)
Dim nameary(1000, 2)

Set fs = Application.FileSearch

With fs
.LookIn = fpath
.Filename = "*.pdd"
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then

For i = 1 To .FoundFiles.Count

nstart = 1
Do Until InStr(nstart, .FoundFiles(i), "\") = 0

nstart = InStr(nstart, .FoundFiles(i), "\") + 1

Loop
nameary(i, 1) = .FoundFiles(i)
nameary(i, 2) = Mid(.FoundFiles(i), nstart)
Next i
Else
MsgBox "There were no files found."
Exit Function
End If
End With
x = 1

get_names = nameary

End Function


Thank you in advance.

[mancubus]

describe your requirement clearly and forget about Application.FileSearch which is not supported after Office 2003.

[SamT]

That functions returns an array, Ubound = 1000, with no or some entries in the form: fpath\filename, filename.

The "instart" loop counts the number of backslashes in fpath for every found file.

Check out the FileSystemObject and the various Get methods in VBA Help

[DLS]

Sorry I didn't give y'all more information. My work gave me a .xla and said "here fix it" upon doing research I find that Application.FileSearch is no longer in the new Excel. I need to some how get that code changed into a new format. There is more code to this program but that is the only part that uses outdated code. The code will scan for the amount of a specific Excel name in a folder and stores them in an array.

fpath is defined by user prompt
.pdd is the file extension that need to be counted .

[DLS]

I have managed to find this code
Public Function get_names(fpath)

Dim fileName As String, ctr As Integer
ctr = 1
fileName = Dir(fpath & "*.pdd")
Do Until fileName = ""
ActiveSheet.Cells(ctr, 1).Value = fpath & fileName
ctr = ctr + 1
fileName = Dir()

Loop

get_names = fileName

End Function
But now I error on this part of the code.

Public Sub Insrt_P_C(fpath)
Dim wks As Worksheet
Dim ccol, crow, pcol, prow, pddcol, pddrow As Integer


Set wks = ActiveSheet

If wks Is Nothing Then

Exit Sub

ElseIf wks.Name <> "Composite" Then

Exit Sub

End If

wks.AutoFilterMode = False

Set tmpcell = wks.UsedRange.Find("Purpose", , xlValues)

If tmpcell Is Nothing Then

Exit Sub

End If

pcol = tmpcell.Column
prow = tmpcell.Row

Set tmpcell = wks.UsedRange.Find("Constraints", , xlValues)

If tmpcell Is Nothing Then

Exit Sub

End If

ccol = tmpcell.Column
crow = tmpcell.Row

Set tmpcell = wks.UsedRange.Find("PDD Name", , xlValues)

If tmpcell Is Nothing Then

Exit Sub

End If

pddcol = tmpcell.Column
pddrow = tmpcell.Row
pdd_files = Functs.get_names(fpath)
'If pdd_files Is Nothing Then

' Exit Sub

'End If

x = 1
Do Until IsEmpty(pdd_files(x, 1)) <----My error is here " Type Mismatch

Set tmpcell = wks.Columns(pddcol).Find(pdd_files(x, 2))

If tmpcell Is Nothing = False Then

firstaddress = tmpcell.Address
pc = Functs.purp_const(pdd_files(x, 1))

Do

wks.Cells(tmpcell.Row, pcol) = pc(1)
wks.Cells(tmpcell.Row, ccol) = pc(2)
Set tmpcell = wks.Columns(pddcol).FindNext(tmpcell)

Loop While Not tmpcell Is Nothing And tmpcell.Address <> firstaddress


Else

MsgBox ("The Following PDD not listed in the Status Log: " & pdd_files(x, 2))

End If

x = x + 1
Loop


End Sub

[Kenneth Hobs]

I don't see how your 2nd sub is getting the values from column A from that function. The function should be a Sub since as is, it only returns one filename.

Obviously, the Dir() is only going to get the root folder filenames and not the subfolder files.

See this thread for some other FSO methods. One of those also uses a class with "some" routines and usage similar to Application.FileSearch. http://www.vbaexpress.com/forum/showthread.php?49366-FileSearch-Macro-error
The class method in this file is also in: https://www.dropbox.com/s/13ycz8jpj6wcnkz/FileSearch.xls?dl=0

My kBatch routine uses the Dir command shell method. http://www.vbaexpress.com/forum/showthread.php?53852-Modify-macro-so-it-searches-files-in-subfolders
The kBatch method is also in this file: https://www.dropbox.com/s/pks2mojoo8gzd5w/kBatch.xlsm?dl=0

[DLS]

I'm new to excel VBA, I learned on the job by looking on a lot of forums and research. Do you happen to know if there is a way to take my first code
Public Function get_names(fpath)
Dim nameary(1000, 2)

Set fs = Application.FileSearch

With fs
.LookIn = fpath
.Filename = "*.pdd"
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then

For i = 1 To .FoundFiles.Count

nstart = 1
Do Until InStr(nstart, .FoundFiles(i), "\") = 0

nstart = InStr(nstart, .FoundFiles(i), "\") + 1

Loop
nameary(i, 1) = .FoundFiles(i)
nameary(i, 2) = Mid(.FoundFiles(i), nstart)
Next i
Else
MsgBox "There were no files found."
Exit Function
End If
End With
x = 1

get_names = nameary

End Function
And get the same results with another set up like dir?

[Kenneth Hobs]

A link that I gave you shows one way to use Dir(). The way you used Dir(), you put the values into column A. You may or may not need that. The purpose of a Function is to return something. The purpose of a Sub is to do things like poking filenames into column A.

I also gave you a link to code and a file that uses Classes. You then use that class similar to how you use Application.Filesearch as shown in the files test routine examples. While seemingly more complicated, your adapted code would just need the classes and then a few lines modifed in your routines that used the old method. The file link used early binding for FSO. Some past examples used early binding for the FSO object which required a reference to the FSO (Microsoft Scripting Runtime).

Howsoever, note that the Filesearch class method does not include the sorting option. I recommend my shell and Dir method for sorting. You can sort arrays after the return of filenames from Dir() and FSO methods though it is less efficient.

To see how to add the sort switch options in the shell's Dir, view this file: http://ss64.com/nt/dir.html
or
Win+R
cmd
enter key
help dir
enter key
exit
enter key

My kBatch file shows the Module kBatch2 routines where it allows you to pass extra parameters like "/ON".

[DLS]

I got this to work now all I need to do is add in ".pdd" as a search




Public Function get_names(fpath)
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim nameary(1000, 2)

'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(fpath)
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
nameary(i + 1, 1) = objFile.Name
'print file path
nameary(i + 1, 2) = objFile.Path
i = i + 1

Next objFile
get_names = nameary
End Function

Any ideas how to implement the search term?

[SamT]

Simple, basic, slow.
Option Explicit

Public Function get_names(fpath)
Dim FileName As String
Dim FilesArray As Variant '(1000, 2)
Dim i As Integer

FileName = Dir(fpath, "*.pdd")
ReDim FilesArray(1000, 2)

Do While FileName <> ""
FilesArray(i, 1) = fpath * FileName
FilesArray(i, 2) = FileName
i = i + 1
FileName = Dir ' Get next entry.
Loop


'MsgBox UBound(filesArray)
ReDim Preserve FilesArray(i)
get_names = FilesArray
'MsgBox UBound(get_names)
End Function

[DLS]

Simple, basic, slow.
Option Explicit

Public Function get_names(fpath)
Dim FileName As String
Dim FilesArray As Variant '(1000, 2)
Dim i As Integer

FileName = Dir(fpath, "*.pdd")
ReDim FilesArray(1000, 2)

Do While FileName <> ""
FilesArray(i, 1) = fpath * FileName
FilesArray(i, 2) = FileName
i = i + 1
FileName = Dir ' Get next entry.
Loop


'MsgBox UBound(filesArray)
ReDim Preserve FilesArray(i)
get_names = FilesArray
'MsgBox UBound(get_names)
End Function


Comes up with "Run-Time error '13': Type mismatch

[SamT]

Sorry, typed commas,and *s instead of &'s and a Syntax error.

Option Explicit
Option Base 1

Public Function get_names(fpath As String) As Variant
'Assumes fpath end is a backslash
Dim fname
Dim FilesArray(1000, 2)
Dim i As Integer
Dim X
X = Dir(fpath & "*")
fname = Dir(fpath & "*")
i = 1

Do While fname <> ""
FilesArray(i, 1) = fpath & fname
FilesArray(i, 2) = fname
i = i + 1
fname = Dir ' Get next entry.
Loop

get_names = FilesArray
End Function

[DLS]

Sorry, typed commas,and *s instead of &'s and a Syntax error.

Option Explicit
Option Base 1

Public Function get_names(fpath As String) As Variant
'Assumes fpath end is a backslash
Dim fname
Dim FilesArray(1000, 2)
Dim i As Integer
Dim X
X = Dir(fpath & "*")
fname = Dir(fpath & "*")
i = 1

Do While fname <> ""
FilesArray(i, 1) = fpath & fname
FilesArray(i, 2) = fname
i = i + 1
fname = Dir ' Get next entry.
Loop

get_names = FilesArray
End Function



I am getting a different error now. "Compile error: ByRef argument type mismatch"

[SamT]

That means the fpath in your code is not same Type as it is in my code. In my code it is Type String.

[DLS]

i noticed your comment said "Assumes fpath end is a backslash" it does not its would be example C:\Program Files

[DLS]

That means the fpath in your code is not same Type as it is in my code. In my code it is Type String.


Private Sub pcbutton_Click()
Dim fpath As String

fpath = pathbox.pdd_path.Value

pathbox.Hide

Call Purp_Constrs_Insert.Insrt_P_C(fpath)

End Sub

It looks to be a string

Added: With me putting a \ it works. Is there a way that wont require the \

[Kenneth Hobs]

I did not add error code checks to check if no files were found.

Dir() and FSO methods tend to return the files in the ascending sorted order. One can use shell Dir's /o:n to force ascending or use /o:-n for descending.

Note that in Main() is where you would add your routine to act on a returned filename. The code there is just an example. I would recommend checking for file extension if needed. Wildcard searches don't always return what one might expect.

The For Each loop in the test routine might be your Main() and in it, call a routine to act on a passed filename as I did in this Main().


Sub test_aFFs()
Dim x() As Variant, v As Variant

'Search filenames and sort, reverse.
'Search on filenames, not directories
x() = aFFs("x:\t*.xls", "/o:-n /a:-d") 'Dir switches: http://ss64.com/nt/dir.html
MsgBox Join(x(), vbLf)

For Each v In x()
Main CStr(v)
Next v
End Sub


'Set extraSwitches, e.g. "/ad", to search folders only.
'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
Optional tfSubFolders As Boolean = False) As Variant

Dim s As String, a() As String, v As Variant
Dim b() As Variant, i As Long

If tfSubFolders Then
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
Else
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
End If

a() = Split(s, vbCrLf)
If UBound(a) = -1 Then
MsgBox myDir & " not found.", vbCritical, "Macro Ending"
Exit Function
End If
ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr

For i = 0 To UBound(a)
If Not tfSubFolders Then
s = Left$(myDir, InStrRev(myDir, "\"))
'add the folder name
a(i) = s & a(i)
End If
Next i
aFFs = sA1dtovA1d(a)
End Function


Function sA1dtovA1d(strArray() As String) As Variant
Dim varArray() As Variant, i As Long
ReDim varArray(LBound(strArray) To UBound(strArray))
For i = LBound(strArray) To UBound(strArray)
varArray(i) = CVar(strArray(i))
Next i
sA1dtovA1d = varArray()
End Function


'script56.chm, http://tinyurl.com/5ts6r8
Sub Main(aFilename As String)
Dim oFSO As Object, sFolder As String, sBasename As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
sFolder = oFSO.GetFile(aFilename).ParentFolder
sBasename = oFSO.GetBasename(aFilename)

Debug.Print "Drive:\Path\Filename.ext:", aFilename
Debug.Print "Folder/Path Name:", sFolder
Debug.Print "Basename:", sBasename
Debug.Print "File Extension:", oFSO.GetExtensionName(aFilename)
Debug.Print vbCrLf
End Sub

[DLS]

So far this code works great
Public Function get_names(fpath) As Variant
'Assumes fpath end is a backslash
Dim fname
Dim FilesArray(1000, 2)
Dim i As Integer
fname = Dir(fpath & "*.pdd")
i = 1

Do While fname <> ""
FilesArray(i, 1) = fpath & fname
FilesArray(i, 2) = fname
i = i + 1
fname = Dir ' Get next entry.
Loop

get_names = FilesArray
End Function

But it requiers a \ after the dir location Example: C:\Program Files\ with out that it wont work.

[DLS]

So far this code works great
Public Function get_names(fpath) As Variant
'Assumes fpath end is a backslash
Dim fname
Dim FilesArray(1000, 2)
Dim i As Integer
fname = Dir(fpath & "*.pdd")
i = 1

Do While fname <> ""
FilesArray(i, 1) = fpath & fname
FilesArray(i, 2) = fname
i = i + 1
fname = Dir ' Get next entry.
Loop

get_names = FilesArray
End Function

But it requiers a \ after the dir location " Example: C:\Program Files\ " with out that it wont work.

[SamT]

You can add the slash:

fname = Dir(fpath & "\*.pdd")
FilesArray(i, 1) = fpath & "\" & fname

OR make the procedure universal

Public Function get_names(fpath) As Variant
'Assumes fpath end is a backslash
Dim fname
Dim FilesArray(1000, 2)
Dim i As Integer

If not Right(fpath, 1) = "\" then fpath = fpath & "\"

fname = Dir(fpath & "*.pdd")
i = 1

Do While fname <> ""
FilesArray(i, 1) = fpath & fname
FilesArray(i, 2) = fname
i = i + 1
fname = Dir ' Get next entry.
Loop

get_names = FilesArray
End Function