Hi everyone,
I would like to search for a file in the C:\ directory with VBA. Unfortunately, the file search functionality has been removed from Microsoft Office 2007 (thus, application.filesearch does not seem to work). I need source code that returns the filepath of an access database to me. Can anyone help?
thanks
Florian
If you know the folder, use DIR.
If you are searching subfolders, a recursive filescripting method can be used. For this method, see http://www.ozgrid.com/forum/showthread.php?t=77491
reposted to http://www.mrexcel.com/forum/showthr...47#post1679147
There are similar filescripting methods on this forum most likely. If you need more help, post back. One can use Match to search an array.
Have found the code you are refering to and adapted it to my needs. The following is the source code as is:
The error occurs on line: 'For Each myFile In fso.GetFolder(myDir).Files'. The error type is Runtime Error '70': Permission denied. Note that I am trying to search the entire drive D:\ for an excel file. Once I copy the excel-file into a folder and search within the folder (regardless of the number of subfolders), the code seems to work. Does this problem have to do with the admin settings? (I am logged on as adminsitrator with all read / write rights). Any ideas?Private myList() As String Sub SearchFiles() myFileSearch _ myDir:="D:", _ FileNameLike:="file", _ FileTypeLike:="xlsm", _ SearchSubFol:=True, _ myCounter:=0 If Join(myList) = "" Then MsgBox "Could not find the requested file.", vbExclamation, "File Search Editor" Else MsgBox "Found the file at:" & vbLf & Join(myList, vbLf) End If End Sub Private Sub myFileSearch(myDir As String, FileNameLike As String, FileTypeLike As String, SearchSubFol As Boolean, myCounter As Long) Dim fso As Object, myFolder As Object, myFile As Object Set fso = CreateObject("Scripting.FileSystemObject") For Each myFile In fso.GetFolder(myDir).Files If myFile.Name Like FileNameLike & "." & FileTypeLike Then myCounter = myCounter + 1 ReDim Preserve myList(1 To myCounter) myList(myCounter) = myDir & "\" & myFile.Name End If Next If SearchSubFol Then For Each myFolder In fso.GetFolder(myDir).SubFolders myFileSearch myDir & "\" & myFolder.Name, FileNameLike, FileTypeLike, True, myCounter Next End If End Sub
thanks in advance
Florian
Last edited by fboehlandt; 09-16-2008 at 06:56 AM.
[VBA]
Private myList() As String
Private n As Long
Sub test()
Dim myDir As String
myDir = "D:\PROJECTS\EXCEL\disabling cut copypaste" '<- folder path (main)
n = 0
SearchFiles myDir, "*.xls*"
If n > 0 Then
GetInfo
Else
MsgBox "No files found"
End If
End Sub
Private Sub SearchFiles(myDir As String, myFileName As String)
Dim fso As Object, myFolder As Object, myFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
For Each myFile In fso.GetFolder(myDir).Files
If (myFile.Name <> ThisWorkbook.Name) * (myFile.Name Like myFileName) Then
n = n + 1
ReDim Preserve myList(1 To 2, 1 To n)
myList(1, n) = myDir & "\" & myFile.Name
myList(2, n) = myFile.Name
End If
Next
For Each myFolder In fso.GetFolder(myDir).SubFolders
SearchFiles myDir & "\" & myFolder.Name, myFileName
Next
End Sub
Private Sub GetInfo()
Dim i As Long, wsName As String, t As Long
wsName = "Sheet 1" '<- make sure that you have space (acc to your post)
With ThisWorkbook.Sheets(1)
.Cells.Clear
For i = 1 To n
t = t + 1
.Cells(t, 1).Value = myList(1, i)
' With .Cells(t, 2).Resize(, 11)
' .Formula = "='" & myList(1, i) & "\[" & myList(2, 1) & "]" & wsName & "'!a3"
' '.Value = .Value
' End With
Next
End With
End Sub
[/vba]
hi Florian,
in this line
SearchFiles myDir, "*.xls*"
change .xls to desired file extension
if u check for whole drive then it will be too slow to work
thanks
sam
Hi Sam,
thanks for you reply. However, your code and the previous one do exactly the same (some differences in how similar files are being looked up). The actual problem is that I want to search an entire harddrive for a specific file (I don't know what folder the file could be located in). Here comes the problem: Whenever I change myDir to D:\ (or C:\ that doesn't really matter --> harddrive partition), the error message is 'permission denied'. The error message makes kind of sense since I'm trying to sift through the 'folder' D:\ (--> see line of coding:
Thus I thought I try the following instead:For Each myFile In fso.GetFolder(myDir).Files
But no joy. Also I wonder what the createobject function actually does. Surely there must be a simple solution to this. Any input is greatly appreciatedFor Each myFile In fso.GetDrive(myDir).Files
I have 2 other methods that should work. This fails for 2 reasons I think. (1) Permission warning when you have a trailing backslash for the directory name. It is a FileScripting limit. The solution is to pass C: rather than C:\ for example. (2) When it encounters a hidden folder like c:\addins. A third limit would be for permission issues.
I will test those methods a bit more before posting back. As they are now, they return the findings to the column A.
I don't actually need the file path returned to me in form of a msg box. I want to use the path in a connection string to import data from one database into another. The source database can be located anywhere on the harddrive. This is the reason why I want to determine the file path of said file
Maybe this will work for you. It may need some tweaks though for the same reasons that the other failed.
If you can send at least one subfolder rather than just the C: Drive, I think either will work fine for you.
[vba]Sub Test4()
Dim a() As String
a = ArrFiles("x:", "DropDownList1.xls", True)
MsgBox a(1, 1)
End Sub
'Similar to: NateO's code, http://www.mrexcel.com/forum/showpos...68&postcount=2
Function ArrFiles(strDir As String, searchTerm As String, _
Optional subFolders As Boolean = True)
Dim fso As Object
Dim strName As String
Dim i As Long
ReDim strArr(1 To Rows.Count, 1 To 1) As String
'strDir must not have a trailing \ for subFolders=True
If Right(strDir, 1) <> "\" Then strDir = strDir & "\"
'Exit if strDir does not exist
If Dir(strDir, vbDirectory) = "" Then Exit Function
Let strName = Dir$(strDir & searchTerm)
Do While strName <> vbNullString
Let i = i + 1
Let strArr(i, 1) = strDir & strName
Let strName = Dir$()
Loop
Set fso = CreateObject("Scripting.FileSystemObject")
'Strip trailing \ if subFolders=False
If subFolders = False Then strDir = Left(strDir, Len(strDir) - 1)
Call recurseSubFolders(fso.GetFolder(strDir), strArr(), i, searchTerm)
Set fso = Nothing
ArrFiles = strArr
End Function
Private Sub recurseSubFolders(ByRef Folder As Object, _
ByRef strArr() As String, _
ByRef i As Long, _
ByRef searchTerm As String)
Dim SubFolder As Object
Dim strName As String
For Each SubFolder In Folder.subFolders
Let strName = Dir$(SubFolder.Path & "\" & searchTerm)
Do While strName <> vbNullString
Let i = i + 1
Let strArr(i, 1) = SubFolder.Path & "\" & strName
Let strName = Dir$()
Loop
Call recurseSubFolders(SubFolder, strArr(), i, searchTerm)
Next
End Sub[/vba]
Thanks for the quick reply. Unfortunately, I'm still getting en error message. This time: 'Run-time error 52: Bad file name or number'. Apparently, the file cannot be found to be returned in a string. Do you know what the issue is here? I replaced the drive and filename incl. the filetype (D:, "testfile.txt"). Anything I might have missed?
Last edited by fboehlandt; 09-16-2008 at 09:12 AM.
See the 2 issues that could cause it to fail as I detailed. The first is that you added a trailing backslash in myDir or strDir. You may have more luck using a UNC path for that first parameter. e.g. //matpc10/myfiles is the same as my D:.
I'll have to look into issue 2 a bit more to see if we can skip Hidden folders.
In this method, I used DOS tricks. DOS requires the folder names with spaces to be enclosed in quotes so I added them in the two tests. This method is more reliable in some cases but can be 2-5 times slower.
I used a wait routine to make sure that DOS has time to create the text file. A ShellWait routine might be a better route that I will have to explore some time.
[vba]Sub Test1()
Dim a As Variant, s As String
s = """" & DesktopFolder & "\*.txt" & """"
a = FileList(s, True)
If UBound(a) = -1 Then Exit Sub
Range("A1").Resize(UBound(a) + 1).Value = WorksheetFunction.Transpose(a)
End Sub
Sub Test2()
Dim a As Variant, s As String
s = """" & "c:\" & "DropDownList1.xls" & """"
a = FileList(s, True)
If UBound(a) = -1 Then
MsgBox "DropDownList1.xls not found."
Exit Sub
End If
Range("A1").Resize(UBound(a) + 1).Value = WorksheetFunction.Transpose(a)
End Sub
Function DesktopFolder()
Dim wshShell As Object
Set wshShell = CreateObject("WScript.Shell")
DesktopFolder = wshShell.specialfolders("Desktop")
End Function
Function FileList(Folder As String, Optional subFolders As Boolean = False) As Variant
Dim sf As String, tFile As String
Dim diff As Long
Dim hFile As Integer, Str As String, vArray As Variant, e As Variant
Dim i As Integer, FolderPart As String
Dim iHandle As Integer
'Search subfolders if subFolders=True
sf = ""
If subFolders = True Then sf = "/s "
'Delete temp file if it exists and create path
tFile = Environ$("temp") & "\FileList.txt"
'If Dir$(tFile) <> "" Then Kill tFile
'Write a 0 byte file
iHandle = FreeFile
Open tFile For Output Access Write As #iHandle
Close #iHandle
'Put files into tFile
Shell Environ$("comspec") & " /c Dir /b " & sf & Folder & " > " & tFile, vbHide
'Wait until file writing is complete
Application.StatusBar = "Writing to " & tFile
diff = 1000
Do Until (diff = 0)
Application.Wait (Now + TimeValue("0:00:01"))
diff = diff - FileLen(tFile) 'Allow time for process to complete
Application.Wait (Now + TimeValue("0:00:01"))
If diff = 0 Then Exit Do
diff = FileLen(tFile)
Loop
Application.StatusBar = ""
'Show tFile in Notepad
'Shell "Notepad " & tFile
'Put tFile contents into an array
hFile = FreeFile
Open tFile For Binary Access Read As #hFile
Str = Input(LOF(hFile), hFile)
Close hFile
vArray = Split(Str, vbCrLf)
'Add base path to vArray elements if needed
FolderPart = Left(Folder, InStrRev(Folder, "\"))
For i = 0 To UBound(vArray)
If InStr(vArray(i), ":") <> 2 Then
vArray(i) = FolderPart & vArray(i)
End If
Next i
On Error Resume Next
ReDim Preserve vArray(0 To UBound(vArray) - 1)
FileList = vArray
End Function
Function FolderPart(sPath As String) As String
FolderPart = Left(sPath, InStrRev(sPath, "\"))
End Function
[/vba]
Holy Moly, thanks for all that effort. I thought this was going to be way easier!(should it not be?) I hate outsourcing work, but I could have never solved this one on my own. It works now!!! Many thanks, this was a huge help! I've been trying to make work for a week...
Cheers
Gald it worked out for you.
I had 98% done already. While we have not gone to 2007 yet, I wanted to review this kind of thing before then. FileSearch is so easy to use in 2003. DIR usually meets the need for less extensive subfolder searches.
This last one would been shorter but I like to put error routines and lots of comments when I design a macro to show others. I added some other parts to make it more modular and handle some other issues. If I get time, I have an idea to make this method a bit faster.
I'll have to explore the filescripting method failures sometime.
hi Florian,
insted of chek the whole drive just check folder in drive then code will not have any error
ex
D:\general where general is folder name.....
Thanks for your input, Sam, but again: the problem is that I need to search the entire drive and not a specific folder. I dont know what folder the target file is in or whether it is in a folder at all. The code posted above by Kenneth works flawlessly and I can recommend it to anyone having the same problem as I do.
Hi Kenneth,Originally Posted by Kenneth Hobs
While I was searching the net for a specific problem of mine, I have faced with an old post of yours in this forum.
My problem is very alike with that user in that post. I'm using Excel 2010 and created a macro workbook and a user manual in pdf form on how to use that macro workbook.
To the workbook_open() procedure, I have written a couple of codes which simply shows the path of the Acrobat Reader's exe file and the path of the manual.pdf and a shell command to execute the reader and open the pdf.
Unfortunately the full path of the Acrobat Reader executable is not the same in the PC's of the users at the office. Because some use Windows XP, some use Windows7 and also differs with 32 and 64bit.
Can you help me modifying your code at the post that I've given so that with a proper VBA code I can get the path for the AcroRd32.exe and pass it to the variable (MyPath) that I use to execute the shell command.
My shell code is something like below:
[VBA]Private Sub Workbook_Open()
If MsgBox("Do you want to read the User Manual for this macro file?", vbYesNo, "USER PROMPT") = vbYes then
MyPath = "C:\Program Files (x86)\Adobe\Reader 9.0\Reader\AcroRd32.exe"
MyFile = ThisWorkbook.path & "\MNT.MCC.MNL.GEN.001-rA.pdf"
Shell MyPath & " " & MyFile, vbNormalFocus
End If
End Sub
[/VBA]
Your help is highly appreciated...thnx
Welcome to the forum!
As part of my response I must point out a few problems with your post to help you with future posts. These rules apply to most all forums.
1. Do not quote too much. That is why we have a thread.
2. Do not hyjack another thread, start your own.
3. If another's thread pertains to what you need, start you own and then post the link to the one that relates.
4. Do not post to a very old thread, see rule (3).
Here is a partial solution. This solution uses the Window's associated programs for a file type. For PDF, you may not get the adobe reader or acobat. For mine, I get PrimoPDF.
The more complete solutions would probably look at registry entries. Try starting a new thread if you have any questions or want to pursue the registry method.
Put this in a Module with the test Sub in that module or another or the event code as you like.
[vba]Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" _
(ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long
Const MAX_FILENAME_LEN = 260
Private Declare Function FindExecutable Lib "shell32.dll" _
Alias "FindExecutableA" (ByVal lpFile As String, _
ByVal lpDirectory As String, ByVal lpResult As String) As Long
Sub test_EXEPath()
MsgBox ExePath("c:\myfiles\wp\t.PDF"), vbInformation, "Path to EXE Program"
End Sub
Public Function ExePath(lpFile As String) As String
Dim s2 As String, i As Long
'Check if the file exists
If Dir(lpFile) = "" Or lpFile = "" Then
ExePath = ""
Exit Function
End If
'Create a buffer
s2 = String(MAX_FILENAME_LEN, 32)
'Retrieve the name and handle of the executable, associated with this file
i = FindExecutable(lpFile, vbNullString, s2)
If i > 32 Then
ExePath = Left$(s2, InStr(s2, Chr$(0)) - 1)
Else
ExePath = ""
End If
End Function
[/vba]
Hi Kenneth,
First of all thnx for your prompt reply. It is highly appreciated and it has worked like a charm!!
Secondly; for your statements about using the forum and threading: they are well understood!
I do apologize for any inconvenience and/or disturbance that I might have caused.
Thnx one again for your help.
Posting Permissions
Reply With Quote
