using Application.FileDialog to rename a file in VBA - vba

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

Related

Excel VBA - Code to open MS Project File not working

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

Sendkeys Only Writing First Character from Text File

I'm trying to write everything from a text file, but it's only writing the first character.
Here's my code:
Sub Main
Dim TextFile As Integer
Dim FilePath As String
Dim FileContent As String
'File Path of Text File
FilePath = "C:\Users\Username\Desktop\Clipboard.txt"
'Determine the next file number available for use by the FileOpen function
TextFile = FreeFile
'Open the text file
Open FilePath For Input As TextFile
'Store file content inside a variable
FileContent = Input(LOF(TextFile), TextFile)
'Report Out Text File Contents
SendKeys FileContent
'Close Text File
Close TextFile
End Sub
I've also tried this, but similarly only write the first character:
Sub Main
Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim objTextStream
Const strFileName = "C:\Users\Username\Desktop\Clipboard.txt"
Const fsoForReading = 1
If objFSO.FileExists("C:\Users\Username\Desktop\Clipboard.txt") Then
'The file exists, so open it and output its contents
Set objTextStream = objFSO.OpenTextFile(strFileName, fsoForReading)
SendKeys objTextStream.ReadAll
objTextStream.close
Set objTextStream = Nothing
Else
'The file did not exist
SendKeys "was not found."
End If
'Clean up
Set objFSO = Nothing
End Sub
Please help. Thanks!
It looks like I needed some more libraries before it would work.
I added Microsoft WMI Scripting Library, OLE Automation, VBA 6, and Visual Basic Runtime Objections. I'm not sure which one fixed it.

VBA Read a texts files: permission denied

I have a folder contain texts files . The text is presented as below :
NAME Number Mail Date
xx 1 zz //
and I want to write a vba code that read all the text files and search for an information "NAME" to replace it with "name"and then save the modifications .
I did the code below , but I have an error 70 permission denied in Set f = FSO.OpenTextFile(Fichier, forWriting, True) ,
could you help me ?
Sub Sample()
dim fso=createobject("scripting.filesystemObject")
dim f
dim path as string
dim file_txt as string
path= "C:\Users\Folder\Fileshere\"
file_txt= Dir(path & "*.*")
Do While Len(file_txt) > 0
'Set objfile = FSO.CreateTextFile(path & file_txt)
Set f = FSO.OpenTextFile(file_txt, ForReading)
While Not f.AtEndOfStream
Namechange = f.ReadAll
Wend
Namechange = Replace(Namechange , "NAME", "name")
Set f = FSO.OpenTextFile(file_txt, forWriting, True)
f.Write Namechange
file_txt=dir()
loop
end sub
I'd rewrite using a bit more of the FileSystemObject functionality rather than using Dir() personally, but that's open to your own choice. The key issue I think you are having is that you have opened the file for reading and then immediately tried to open it for writing while the TextStream object is still in memory, and locking the file. This is why you are getting "Permission denied". To quote from a TechNet Article:
Opening Text Files
Working with text files is a three-step process.
Before you can do anything else, you must open the text file. This can
be done either by opening an existing file or by creating a new text
file. (When you create a new file, that file is automatically opened
and ready for use.) Either approach returns a reference to the
TextStream object. After you have a reference to the TextStream
object, you can either read from or write to the file. However, you
cannot simultaneously read from and write to the same file. In other
words, you cannot open a file, read the contents, and then write
additional data to the file, all in the same operation. Instead, you
must read the contents, close the file, and then reopen and write the
additional data. When you open an existing text file, the file can be
opened either for reading or for writing. When you create a new text
file, the file is open only for writing, if for no other reason than
that there is no content to read. Finally, you should always close a
text file. Although this is not required (the file will generally be
closed as soon as the script terminates), it is good programming
practice.
My code should work for your requirements. I've removed the While loop from the middle as if you are using ReadAll then you don't need to loop over the text.
Sub MySub()
Dim fso
Set fso = CreateObject("scripting.filesystemObject")
Dim file, folder
Dim path As String
Dim file_txt As String
path = "C:\users\folders\fileshere\"
Set folder = fso.GetFolder(path)
For Each file In folder.Files
Set file = fso.OpenTextFile(file.Path, 1)
Namechange = file.ReadAll
file.Close
Namechange = Replace(Namechange, "NAME", "name")
Set file = fso.OpenTextFile(file.Path, 2, True)
file.Write Namechange
file.Close
Next
End Sub
If you have any difficulties or would like further explanation of the above, let me know.
Some minor changes and it worked for me. Please change the path as per your own requirement in following code:
Sub change_txt()
Dim fso As Object
Set fso = CreateObject("scripting.filesystemObject")
Dim f
Dim path As String
Dim file_txt As String
path = "D:\Folder\Fileshare\"
file_txt = Dir(path & "*.*")
Do While Len(file_txt) > 0
'Set objfile = FSO.CreateTextFile(path & file_txt)
Set f = fso.opentextfile(path & file_txt, 1)
While Not f.AtEndOfStream
Namechange = f.ReadAll
Wend
Namechange = Replace(Namechange, "NAME", "name")
Set f = fso.opentextfile(path & file_txt, 2)
f.Write Namechange
file_txt = Dir()
Loop
End Sub

VBA excel: how to add text to all files on a folder

I need to add text string to all files on a folder, as a footer
For example, on the folder on the path and called C:\mobatchscripts\
I have a random number of txt files, with text.
I want to add a line for example "text" on each of the text files on the folder
I have little knowledge of vba programming, but for what I have read I can use append, but I need something that loop on the files on the folder, and modify them.
So far I tried this:
Sub footer()
Dim FolderPath As String
Dim FileName As String
Dim wb As Excel.Workbook
FolderPath = "C:\mobatchscripts\"
FileName = Dir(FolderPath)
Do While FileName <> ""
Open FileName For Append As #1
Print #1, "test"
Close #1
FileName = Dir
Loop
End Sub
But seems that its not looking into the files, or appending the text.
On the assumption that you're writing to text files (I see "batchscripts" in the path), you need a reference to the Microsoft Scripting Runtime (Within the VBE you'll find it in Tools, References)
Option Explicit
Public Sub AppendTextToFiles(strFolderPath As String, _
strAppendText As String, _
blnAddLine As Boolean)
Dim objFSO As FileSystemObject
Dim fldOutput As Folder
Dim filCurrent As File
Dim txsOutput As TextStream
Set objFSO = New FileSystemObject
If objFSO.FolderExists(strFolderPath) Then
Set fldOutput = objFSO.GetFolder(strFolderPath)
For Each filCurrent In fldOutput.Files
Set txsOutput = filCurrent.OpenAsTextStream(ForAppending)
If blnAddLine Then
txsOutput.WriteLine strAppendText
Else
txsOutput.Write strAppendText
End If
txsOutput.Close
Next
MsgBox "Wrote text to " & fldOutput.Files.Count & " files", vbInformation
Else
MsgBox "Path not found", vbExclamation, "Invalid path"
End If
End Sub
I'd recommend adding error handling as well and possibly a check for the file extension to ensure that you're writing only to those files that you want to.
To add a line it would be called like this:
AppendTextToFiles "C:\mobatchscripts", "Test", True
To just add text to the file - no new line:
AppendTextToFiles "C:\mobatchscripts", "Test", False
Alternatively, forget the params and convert them to constants at the beginning of the proc. Next time I'd recommend working on the wording of your question as it's not really very clear what you're trying to achieve.

Excel Saving to TXT file

I have this script that I'd like to in addition save as a xls file, also save as a .txt in the same directory, or even a different one. Can I get some guidance here?
Imports System.IO
Module Module1
Private Property fs As Object
Private Property BaseName As Object
Private Property FullTargetPath As Object
Sub Main()
Dim targetfolder As String = "C:\TEST"
Dim sourcefolder As String = "\\10.97.8.16\c$\Checks\XMLFiles"
Dim Searchpattern As String = String.Format("{0:MM-dd-yyyy}*.xml", Date.Today)
Dim todaysfiles() As String = Directory.GetFiles(sourcefolder, Searchpattern)
Dim xlApp, xlWkb
xlApp = CreateObject("excel.application")
fs = CreateObject("Scripting.FileSystemObject")
Const xlnormal = 1
'Extra Dims
'Hide Excel
xlApp.Visible = False
For Each file As String In todaysfiles
' Excel stuff... '
Dim fileName As String = IO.Path.GetFileNameWithoutExtension(file)
' Concatenate full path. Extension will be automatically added by Excel. '
Dim fullTargetPath = IO.Path.Combine(targetfolder, fileName)
'Process each file in SourceFolder
' For Each file In fs.GetFolder(SourceFolder).files
'Open file in SourceFolder
xlWkb = xlApp.Workbooks.Open(file)
'Get Filename
BaseName = fs.getbasename(file)
'Concatenate full path. Extension will be automatically added by Excel
fullTargetPath = targetfolder & "\" & BaseName
'Save as XLS file into TargetFolder
xlWkb.SaveAs(fullTargetPath, xlnormal)
'Close the file after its done
xlWkb.close()
Next
xlWkb = Nothing
xlApp = Nothing
fs = Nothing
' MsgBox("Thank you. Currently the Date is: " & Date.Today & " people like to eat chicken Every " & Date.Today.Ticks & " minutes.")
'This is for extra code below
End Sub
End Module
Pretty much exactly as you are doing now, but change the format in from xlnormal to xltext.
xlWkb.SaveAs(fullTargetPath, xltext)
When researching something like this I like to look around the object browser under vba editor. Look up Workbook object in this case and then the SaveAs sub to get the definition (parameters and types) then you can click on the parameter you want more information on and look it up from the help menu. I say that from memory I have not played with excel macros in years. Good luck!
Why can't you call
xlWb.SaveAs(fullTargetPath, XlFileFormat.xlTextWindows)
or with any other xlFileFormat type?