I would like to search a file in user-defined directory. My file structure like that xxx__description__myFileName__YYMMDD.txt there'll be multiple versions of this file so I want to list all files in directory which includes myFileName in their filename. Also I don't know is it the efficient way to list files with such type of code.
I tried to use this code but it gives me an error:
Run-time error '445': Object doesn't support this action
Sub findFiles()
Dim i As Integer
Dim myFile As String
myFileName = "ABC123"
With Application.FileSearch
.NewSearch
.LookIn = "C:\myTestDirectory"
.fileName = "*myFileName*.xlsx"
.SearchSubFolders = True
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Debug.Print .FoundFiles(i)
Next i
End If
End With
End Sub
Related
I wrote some code to allow me to select an MS Project file and open it, however when I run the code, nothing happens.
Zero errors, it just exits, any suggestions with what i'm doing wrong here?
Code below
Sub START()
' MS Project variables
Dim Proj As MSProject.Application
Dim NewProj As MSProject.Project
'File Name Variables
Dim FileOpenType As Variant
Dim NewProjFileName As String
Dim NewProjFilePath As String
Dim NewProjFinal As String
'Code to find and open project files
Set Proj = CreateObject("MsProject.Application")
MsgBox ("Please Select MS Project File for Quality Checking")
'Select Project File
FileOpenType = Application.GetOpenFilename( _
FileFilter:="MS Project Files (*.mpp), *.mpp", _
Title:="Select MS Project file", _
MultiSelect:=False)
'Detect if File is selected, if not then stop code
If FileOpenType = False Then
MsgBox ("You Havent Selected a File")
GoTo EndPoint
End If
'Write the FileOpenType variant to two separate strings
NewProjFilePath = Left$(FileOpenType, InStrRev(FileOpenType, "\"))
NewProjFileName = Mid$(FileOpenType, InStrRev(FileOpenType, "\") + 1)
'Open Project File
Proj.FileOpen NewProjFilePath & NewProjFileName
EndPoint:
End Sub
Just a couple of notes:
First, since you are using Early Binding to refer to MS-Project, so instead of setting Set Proj = CreateObject("MsProject.Application"), which is used for Late Binding, you can use Set Proj = New MSProject.Application.
Second: since Proj is defined as MSProject.Application, in order to make the MS-Project application visible, it's enough to use Proj.Visible = True.
Code
Option Explicit
Sub START()
' MS Project variables
Dim Proj As MSProject.Application
Dim NewProj As MSProject.Project
'File Name Variables
Dim FileOpenType As Variant
Dim NewProjFileName As String
Dim NewProjFilePath As String
Dim NewProjFinal As String
Set Proj = New MSProject.Application ' since you are using Early binding, you can use this type of setting a new MS-Project instance
MsgBox "Please Select MS Project File for Quality Checking"
'Select Project File
FileOpenType = Application.GetOpenFilename( _
FileFilter:="MS Project Files (*.mpp), *.mpp", _
Title:="Select MS Project file", _
MultiSelect:=False)
If FileOpenType = False Then
MsgBox "You Havent Selected a File"
Exit Sub ' <-- use Exit Sub instead of GoTo EndPoint
End If
'Write the FileOpenType variant to two separate strings
NewProjFilePath = Left$(FileOpenType, InStrRev(FileOpenType, "\"))
NewProjFileName = Mid$(FileOpenType, InStrRev(FileOpenType, "\") + 1)
'Open Project File
Proj.FileOpen NewProjFilePath & NewProjFileName
Proj.Visible = True ' <-- Set MS-Project as visible application
End Sub
Resolved by adding the following line, edited code to show
Proj.Application.Visible = True
I run this vba which goes through folders and pulls data which it compiles together in one big sheet. My issue is I was getting errors for hidden files called thumbs.db and I need to add something so that it verifies that it is only pulling files with xlsx extensions. Below is the code I am using.
Sub DoFolder(Folder)
Dim SubFolder As Folder
Dim i As Integer
Dim CopyR As Range
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
If Folder.SubFolders.Count = 0 Then
If Folder.Files.Count = 1 Then
If Mid(Folder.Files, Len(Folder.Files) - 3, 4) = "xlsx" Then
Else: MsgBox "2+ files: " & Folder.Path
End If
End If
For Each File In Folder.Files
Hoover File
Next
Else
End If
End Sub
The line I am having issues with figuring out is
If Mid(Folder.Files, Len(Folder.Files) - 3, 4) = "xlsx" Then
Any help on this would be really appreciated
Folder.Files is a collection not a string.
Recursive File Search:
Sub DoFolder(FolderName As String, Optional fso As Object)
Dim f As Object, MySubFolder As Object, RootFolder As Object
Dim cFiles As Collection
If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject")
Set RootFolder = fso.GetFolder(FolderName)
For Each MySubFolder In RootFolder.SubFolders
DoFolder MySubFolder.Path, fso
Next
Set cFiles = New Collection
For Each f In RootFolder.Files
If f.Name Like "*xls*" Then cFiles.Add f
Next
If cFiles.Count > 0 Then
MsgBox cFiles.Count & " files found in " & RootFolder.Name
For Each f In cFiles
Hoover f
Next
End If
End Sub
A quick solution is simply to check for xlsx being contained in the name of the file. Like this:
If InStr(1,"FileName","xlsx",vbTextCompare)<1 then
Thus, you would be in the safe side, unless someone renames thumbs.db to thumbsxlsx.db.
Assuming you're using the FileSystemObject, which it looks like you are even though we can't see the declarations, and assuming you're only wanting to call Hoover for .xlsx files you can use the following code
If Right(File.Name, 4) = "xlsx" Then
Hoover File
End If
As a further improvement to the answer by user6432984.. FSO does have a function to obtain the file extension, but the function is not part of the File object, but is the fso.GetExtensionName()
You would expect that the File.Type property could be used, but that gives the application name associated with that file extension - not very useful.
If f.Type Like "*xls*" Then cFiles.Add f
However the FSO-based function works as follows:
For Each f In RootFolder.Files
If fso.GetExtensionName(f.Path) Like "*xls*" Then cFiles.Add f
Next
Kindly do not mark duplicate as I have properly checked for other related solutions specific to Error 91 but none of those seem to fetch me the solution for the problem I am facing .
Am trying to convert my coreldraw files nested in various folders (about 500 files ) using the following VBA code but its either crashing the application or showing the Error 91 'Object or With Block Variable not set'. The same code absolutely works fine when used with the other Demo Set of files which i created to test.
One case I could presume is the file showing some dialog when processing the script. If yes how should I prevent those dialog boxes. Application.DisplayAlerts = False not working in coreldraw.
But however that case is only an assumption. Can someone help me find the problem. Heres the code
Sub NewFolder()
Dim FileSystem As Object
Dim HostFolder As String
HostFolder = "My folder Path"
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
End Sub
Sub DoFolder(folder)
Dim SubFolder
For Each SubFolder In folder.SubFolders
DoFolder SubFolder
Next
Dim File
For Each File In folder.Files
If InStr(File.Name, ".cdr") Then
Application.OpenDocument (File)
End If
Dim filepath As String
filepath = ActiveDocument.FullFileName
Dim doc1 As Document
Dim SaveOptions As StructSaveAsOptions
Set SaveOptions = CreateStructSaveAsOptions
Set doc1 = ActiveDocument
With SaveOptions
.EmbedVBAProject = True
.Filter = cdrCDR
.IncludeCMXData = False
.Range = cdrAllPages
.EmbedICCProfile = True
.Version = cdrVersion17
End With
doc1.SaveAs filepath, SaveOptions
doc1.Close
' Operate on each file
Next
End Sub
I'd say you must check if a valid corel draw file has been found
I don't know CorelDraw VBA but I'd assume you could get the following code as a good start:
Sub DoFolder(folder)
Dim SubFolder
For Each SubFolder In folder.SubFolders
DoFolder SubFolder
Next
Dim file
Dim doc1 As Document
Dim filepath As String
Dim SaveOptions As StructSaveAsOptions
For Each file In folder.Files
If InStr(file.Name, ".cdr") Then
Set doc1 = GetDocument(file) '<--| try and get a valid CorelDraw document with the given file: see 'GetDocument()' function at the bottom
If Not doc1 Is Nothing Then '<--| if you succeed then go on with your code
filepath = ActiveDocument.FullFileName
Set SaveOptions = CreateStructSaveAsOptions
With SaveOptions
.EmbedVBAProject = True
.Filter = cdrCDR
.IncludeCMXData = False
.Range = cdrAllPages
.EmbedICCProfile = True
.Version = cdrVersion17
End With
doc1.SaveAs filepath, SaveOptions
doc1.Close
End If
End If
' Operate on each file
Next
End Sub
Function GetDocument(file As Variant) As Document
On Error Resume Next
Set GetDocument = OpenDocument(file)
End Function
as a side note I collected all Dim statements outside loops not to have them run multiple time uselessly
I'm using the code by Ron (http://www.rondebruin.nl/win/s7/win002.htm) to, in theory, unzip a bunch of zip files in a folder. I believe what I have below is the code that takes each zip file in my 'Downloads' directory, creates a new folder with the name of the zip file without the ".zip", and then extracts the files into the new folder. I am not getting any errors (many times people get the runtime error 91) but the only thing that happens is that it creates a bunch of correctly named folders but they are all empty.
Sub UnZipMe()
Dim str_FILENAME As String, str_DIRECTORY As String, str_DESTINATION As String
'Your directory where zip file is kept
str_DIRECTORY = "C:\Users\Jennifer\Downloads\"
'Loop through all zip files in a given directory
str_FILENAME = Dir(str_DIRECTORY & "*.zip")
Do While Len(str_FILENAME) > 0
Call Unzip1(str_DIRECTORY & str_FILENAME)
Debug.Print str_FILENAME
str_FILENAME = Dir
Loop
End Sub
Sub Unzip1(str_FILENAME As String)
Dim oApp As Object
Dim Fname As Variant
Dim FnameTrunc As Variant
Dim FnameLength As Long
Fname = str_FILENAME
FnameLength = Len(Fname)
FnameTrunc = Left(Fname, FnameLength - 4) & "\"
If Fname = False Then
'Do nothing
Else
'Make the new folder in root folder
MkDir FnameTrunc
'Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FnameTrunc).CopyHere oApp.Namespace(Fname).items
End If
End Sub
The problem is you are not giving windows enough time to extract the zip file. Add DoEvents after the line as shown below.
TRIED AND TESTED
oApp.Namespace(FnameTrunc).CopyHere oApp.Namespace(Fname).items
DoEvents
Using VBA. My script moves a file into a directory. If that filename already exists in the target directory, I want the user to be prompted to rename the source file (the one that's being moved) before the move is executed.
Because I want the user to know what other files are in the directory already (so they don't choose the name of another file that's already there), my idea is to open a FileDialog box listing the contents of the directory, so that the user can use the FileDialog box's native renaming capability. Then I'll loop that FileDialog until the source file and target file names are no longer the same.
Here's some sample code:
Sub testMoveFile()
Dim fso As FileSystemObject
Dim file1 As File
Dim file2 As File
Dim dialog As FileDialog
Set fso = New FileSystemObject
fso.CreateFolder "c:\dir1"
fso.CreateFolder "c:\dir2"
fso.CreateTextFile "c:\dir1\test.txt"
fso.CreateTextFile "c:\dir2\test.txt"
Set file1 = fso.GetFile("c:\dir1\test.txt")
Set file2 = fso.GetFile("c:\dir2\test.txt")
Set dialog = Application.FileDialog(msoFileDialogOpen)
While file1.Name = file2.Name
dialog.InitialFileName = fso.GetParentFolderName(file2.Path)
If dialog.Show = 0 Then
Exit Sub
End If
Wend
file1.Move "c:\dir2\" & file1.Name
End Sub
But when I rename file2 and click 'OK', I get an error:
Run-time error '53': File not found
and then going into the debugger shows that the value of file2.name is <File not found>.
I'm not sure what's happening here--is the object reference being lost once the file's renamed? Is there an easier way to let the user rename from a dialog that shows all files in the target directory? I'd also like to provide a default new name for the file, but I can't see how I'd do that using this method.
edit: at this point I'm looking into making a UserForm with a listbox that gets populated w/ the relevant filenames, and an input box with a default value for entering the new name. Still not sure how to hold onto the object reference once the file gets renamed, though.
Here's a sample of using Application.FileDialog to return a filename that the user selected. Maybe it will help, as it demonstrates getting the value the user provided.
EDIT: Modified to be a "Save As" dialog instead of "File Open" dialog.
Sub TestFileDialog()
Dim Dlg As FileDialog
Set Dlg = Application.FileDialog(msoFileDialogSaveAs)
Dlg.InitialFileName = "D:\Temp\Testing.txt" ' Set suggested name for user
' This could be your "File2"
If Dlg.Show = -1 Then
Dim s As String
s = Dlg.SelectedItems.Item(1) ` Note that this is for single-selections!
Else
s = "No selection"
End If
MsgBox s
End Sub
Edit two: Based on comments, I cobbled together a sample that appears to do exactly what you want. You'll need to modify the variable assignments, of course, unless you're wanting to copy the same file from "D:\Temp" to "D:\Temp\Backup" over and over. :)
Sub TestFileMove()
Dim fso As FileSystemObject
Dim SourceFolder As String
Dim DestFolder As String
Dim SourceFile As String
Dim DestFile As String
Set fso = New FileSystemObject
SourceFolder = "D:\Temp\"
DestFolder = "D:\Temp\Backup\"
SourceFile = "test.txt"
Set InFile = fso.GetFile(SourceFolder & SourceFile)
DestFile = DestFolder & SourceFile
If fso.FileExists(DestFile) Then
Dim Dlg As FileDialog
Set Dlg = Application.FileDialog(msoFileDialogSaveAs)
Dlg.InitialFileName = DestFile
Do While True
If Dlg.Show = 0 Then
Exit Sub
End If
DestFile = Dlg.Item
If Not fso.FileExists(DestFile) Then
Exit Do
End If
Loop
End If
InFile.Move DestFile
End Sub
Here's some really quick code that I knocked up but basically looks at it from a different angle. You could put a combobox on a userform and get it to list the items as the user types. Not pretty, but it's a start for you to make more robust. I have hardcoded the directory c:\ here, but this could come from a text box
Private Sub ComboBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger,
ByVal Shift As Integer)
Dim varListing() As Variant
Dim strFilename As String
Dim strFilePart As String
Dim intFiles As Integer
ComboBox1.MatchEntry = fmMatchEntryNone
strFilePart = ComboBox1.Value
strFilename = Dir("C:\" & strFilePart & "*.*", vbDirectory)
Do While strFilename <> ""
intFiles = intFiles + 1
ReDim Preserve varListing(1 To intFiles)
varListing(intFiles) = strFilename
strFilename = Dir()
Loop
On Error Resume Next
ComboBox1.List() = varListing
On Error GoTo 0
ComboBox1.DropDown
End Sub
Hope this helps. On error resume next is not the best thing to do but in this example stops it erroring if the variant has no files