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?
Related
I want to convert all docx files in a folder to PDF.
To accomplish my goals I put all the files (only docx) in the same folder than the docm and run the macro. It worked, but now it doesn't, even with the same files doesn't work anymore. Sometimes works for the first file and stop working with the following alert:
"Runtime error '5174':
This file could not be found
(C:\Users...\Archive.docx)"
The problem is always on the Documents.Open
Tried "OpenAndRepair", "ReadOnly", Putting nothing, etc.
Sub Converter()
Dim CurrentFolder As String
Dim FileName As String
Dim myPath As String
'Store Information About Word File
myPath = ActiveDocument.FullName
FileName = Mid(myPath, InStrRev(myPath, "\") + 1)
Dim strCaminho As String
strCaminho = ActiveDocument.Path
Dim fso As Object 'Scripting.FileSystemObject
Dim fld As Object 'Scripting.Folder
Dim fl As Object 'Scripting.File
Dim atual As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strCaminho)
For Each fl In fld.Files
If fl.Name <> FileName Then 'doesn't try to open the file with macro
Documents.Open FileName:=fl.Name
Word_ExportPDF 'A function that works
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
End If
Next fl
End Sub
My code is a Frankenstein from other macros, is there a better way to Automatize this conversion?
Implement what Comintern had proposed:
You don't need to parse out the FileName - Word.Document give you direct access to that with .Name. The first thing I would do is collect the names of the documents first, then export them. You're modifying the directory contents as you iterate over it. - Comintern
Then, the following can be added to the code to check for valid document extensions:
If fl.Name <> FileName Then 'doesn't try to open the file with macro
If LCase(fso.GetExtensionName(fl.Path)) = "docx" Then '<----This Line
Documents.Open FileName:=fl.Path '<--------------------This Line
Word_ExportPDF 'A function that works
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
End if
End if
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'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.
I'm looping through an input file and using the readline command to read each line, check it for various criteria, then I want to make changes based on the result. Here is a very simple version of what I'm trying to do:
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(strFileLoc, 1)
Do While Not objFile.AtEndOfStream
strLineRead = objFile.readline
if strLineRead Like "*text to change*" Then
'Some code to change the line
end if
Loop
What I've been doing is saving the entire file to a string called strFileText, and then using a Replace function to replace the strLineRead within that string with the changed version. Something like this:
strFileText = Replace(strFileText, strLineRead, strNewLine)
and then write that entire string to a new text file.
The problem is, sometimes I might have a line where it's entire text is "NC", and then doing a find/replace on the entire file for "NC" changes more than just the one line.
So is there a command in the FileSystemObject, while on a certain line, to be able to alter the file directly? I'm thinking something like a "writeline" command.
Have these private subs somewhere in your file and on an event, call them. First call replace_text and fill it with the requirements. See my sample code.
Private Sub Command3_Click()
Dim sFileName As String
Dim fileSys As Variant
' Edit as needed
sFileName = Me.FileList.Value
Set fileSys = CreateObject("Scripting.FileSystemObject")
Replace_Text sFileName, "bad text", "good text", fileSys
End Sub
Private Sub Replace_Text(targetFile As String, targetText As String, replaceText As String, fileSys As Variant)
If Right(targetFile, 3) = "filepath extension you want (example: xml or doc etc.)" Then
Update_File targetFile, targetText, replaceText, fileSys
Else
MsgBox "You did not select the right file. Please try again."
End If
End Sub
Private Sub Update_File(fileToUpdate As String, targetText As String, replaceText As String, fileSys As Variant)
Dim tempName As String
Dim tempFile As Variant
Dim file As Variant
Dim currentLine As String
Dim newLine As String
'creates a temp file and outputs the original files contents but with the replacements
tempName = fileToUpdate & ".tmp"
Set tempFile = fileSys.CreateTextFile(tempName, True)
'open the original file and for each line replace any matching text
Set file = fileSys.OpenTextFile(fileToUpdate)
Do Until file.AtEndOfStream
currentLine = file.ReadLine
newLine = Replace(currentLine, targetText, replaceText)
'write to the new line containing replacements to the temp file
tempFile.WriteLine newLine
Loop
file.Close
tempFile.Close
'delete the original file and replace with the temporary file
fileSys.DeleteFile fileToUpdate, True
fileSys.MoveFile tempName, fileToUpdate
End Sub
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