VBscript Replace text with part of filename - vbscript

I have a directory of files that I want to Loop through and use part of their filename to replace text in a template doc.
For example one filename may be 'NV_AD32_city.dxf'. All files in the directory follow the same filename pattern of XX_XXXX_string.dxf, using two underscores.
I need to capture the string to the right of the first "_" and to the left of the "."so for this example that would be 'AD32_city'
How do I script to use capture that text of the active file to replace text in the template? I guess I need to create an object? But what is the object to use for the current file from a directory?
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Thx for the replies, guys. After several days of trying your code I am just not "getting it". I understand it is set up to take the part of the filename's string that I want but how do I tell the script to use the current file I am looping through? Here is my script so far. I have your code on line 20 under the Sub 'GetNewInputs'
Set fso = CreateObject("Scripting.FileSystemObject")
Option Explicit
Dim WritePath : WritePath = "S:\TempFolder\"
Dim OutFile : OutFile = "VEG_DXF-2-SHP_script-"
Dim WorkingFile : WorkingFile = GetFileContent(SelectFile())
Dim NewState, NewSection, NewArea
Dim OldState, OldSection, OldArea
Call GetNewInputs()
Call GetOldInputs()
Sub GetNewInputs()
NewState = UCase(InputBox("INPUT STATE:", _
"INPUT STATE", "SOCAL"))
NewSection = ("Section_" & InputBox("INPUT SECTION NUMBER:", _
"INPUT SECTION", "14"))
NewArea = "^[^_]+_(.*)\.dxf$"
End Sub
Private Sub GetOldInputs()
OldState = "XX"
OldSection = "_X"
OldArea = "ZZZZ"
End Sub
Function SelectFile()
SelectFile = vbNullString
Dim objShell : Set objShell = WScript.CreateObject("WScript.Shell")
Dim strMSHTA : strMSHTA = "mshta.exe ""about:" & "<" & "input type=file id=FILE>" _
&"<" & "script>FILE.click();new ActiveXObject('Scripting.FileSystemObject')" _
&".GetStandardStream(1).WriteLine(FILE.value);close();resizeTo(0,0);" & "<" & "/script>"""
SelectFile = objShell.Exec(strMSHTA).StdOut.ReadLine()
If SelectFile = vbNullString Then
WScript.Echo "No file selected or not a text file."
WScript.Quit
End If
End Function
Private Function GetFileContent(filePath)
Dim objFS, objFile, objTS
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFile = objFS.GetFile(filePath)
Set objTS = objFile.OpenAsTextStream(1, 0)
GetFileContent = objTS.Read(objFile.Size)
Set objTS = Nothing
End Function
For Each FileRefIn fso.GetFolder("S:\SOCAL\Section_14\Veg DXFs\").Files
NewFile = WorkingFile
NewFile = Replace(NewFile, OldState, NewState)
NewFile = Replace(NewFile, OldSection, NewSection)
NewFile = Replace(NewFile, OldArea, NewArea)
WriteFile NewFile, WritePath & OutFile & ".gms"
WScript.Echo NewArea
Next
Private Sub WriteFile(strLine,fileName)
On Error Resume Next
Dim objFSO, objFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
Do Until IsObject(objFile)
Set objFile = objFSO.OpenTextFile(fileName, 8, True)
Loop
objFile.WriteLine strLine
objFile.Close
End Sub

Well, that’s actually two questions.
To enumerate files in a directory, you can use FileSystemObject, like this (untested)
const strFolderPath = "C:\Temp\Whatever"
set objFSO = CreateObject( "Scripting.FileSystemObject" )
set objFolder = objFSO.GetFolder( strFolderPath )
set colFiles = objFolder.Files
for each objFile in colFiles
' Do whatever you want with objFile
next
Here's the reference of those objects properties/methods.
And to extract portion of file names, you could use a regular expression.
Here’s some guide how to use'em in VBScript.
The following expression should work for you, it will capture the portion of that file names you asked for:
"^[^_]+_(.*)\.dxf$"

If you need to edit the content of the .dxf files, you will need to work within the AutoCAD VBA (Visual Basic for Applications) environment.
If that is the case, you will need to start with something like below:
GetObject("AutoCAD.Application.20")
CreateObject("AutoCAD.Application.20")
https://knowledge.autodesk.com/search-result/caas/CloudHelp/cloudhelp/2015/ENU/AutoCAD-ActiveX/files/GUID-0225808C-8C91-407B-990C-15AB966FFFA8-htm.html
** Please take note that "VBA is no longer distributed with the AutoCAD installation; it must be downloaded and installed separately. The VBA Enabler for Autodesk AutoCAD can be downloaded here."

Related

variable isnt updating as the code loops through

Ive written some code that loops through text files in a folder and updates them with an addiotnal header "TREATMENT_CODE" and then appends a code to the end of each line within each text file. The code is taken from the txt file name. Ive set this as a variable called TCode. The problem Im having is that the TCode variable isn't changing after the first loop through. Can anybody help? Thanks
Please excuse all of the msgbox lines, just me using them to figure out whats going on.
Code:
Option Explicit
Dim FSO, FLD, FIL, TS
Dim strFolder, strContent, strPath, FileName, PosA, TCode, rfile, Temp, dataToAppend, fulldata, wfile, TempArr, i
Const ForReading = 1, ForWriting = 2, ForAppending = 8
'Change as needed - this names a folder at the same location as this script
strFolder = "C:\Users\User1\OneDrive - Company/Documents\Temporary_delete_every_month\CRM_combiner_macro\Looping_test\files to amend"
'Create the filesystem object
Set FSO = CreateObject("Scripting.FileSystemObject")
'Get a reference to the folder you want to search
set FLD = FSO.GetFolder(strFolder)
'loop through the folder and get the file names
For Each Fil In FLD.Files
'MsgBox Fil.Path
'If UCase(FSO.GetExtensionName(Fil.Name)) = ".txt" Then
strPath = Fil.Path
'msgbox strPath
'strPath = Replace(strPath,"""","")
'msgbox strPath
posA = InStrRev(strPath, "\") +1
TCode = "|" & Mid(strPath, posA, 11)
msgbox "this is TCode " & TCode
Set fso = CreateObject("scripting.filesystemobject")
'msgbox "next file to amend" & strPath
Set rfile = fso.OpenTextFile(strPath, ForReading) 'File opened in Read-only mode
While Not rfile.AtEndOfStream
temp=rfile.ReadLine()
If rfile.Line=2 Then
dataToAppend = "|TREATMENTCODE"
ElseIf rfile.Line=3 Then
dataToAppend = TCode
End If
fulldata = fulldata & temp & dataToAppend & "|||"
Wend
rfile.Close
fulldata = Left(fulldata,Len(fulldata)-2)
Set wfile = fso.OpenTextFile(strPath, ForWriting) 'File opened in write mode
tempArr = Split(fulldata,"|||")
For i=0 To UBound(tempArr)
wfile.WriteLine tempArr(i)
Next
wfile.Close
Set fso= Nothing
'End If
'Clean up
Set TS = Nothing
Set FLD = Nothing
Set FSO = Nothing
set rfile = Nothing
set wfile = Nothing
set tempArr = Nothing
set Temp = Nothing
set TCode = Nothing
Next
MsgBox "Done!"

Saving file into another file using VBScript after modification

I have some XML files in a folder \\demo.US\Modified\. The files in the folder are:
USA.xml
Canada.xml
Mexico.xml
The code below is changing the encoding from UTF-8 to windows-1252 and is creating a modified file mod.xml.
This mod.xml file have data from all three XML files concatenated.
I need help so I can save files separately.
If value of objFile.Name is USA.xml then it should save modified file name as USA_mod.xml. the output for \\demo.US\Modified\ folder after execution is complete should have mod files in it as below.
USA.xml
Canada.xml
Mexico.xml
USA_mod.xml
Canada_mod.xml
Mexico_mod.xml
The code I used is as follows.
Set objFSO = CreateObject("Scripting.FileSystemObject")
objStartFolder = "\\demo.US\Modified\"
Set objFolder = objFSO.GetFolder(objStartFolder)
Set colFiles = objFolder.Files
For Each objFile In colFiles
WScript.Echo objFile.Name
Set objFile = objFSO.OpenTextFile(objStartFolder & objFile.Name, 1)
Set outFile = objFSO.OpenTextFile(objStartFolder & "mod.xml", 2, True)
Do Until objFile.AtEndOfStream
strContent = strContent & objFile.ReadLine
Loop
MsgBox strContent
strContent = Replace(strContent, "encoding=""UTF-8""", "encoding=""windows-1252""")
outFile.WriteLine strContent
outFile.Close
objFile.Close
Next
As others have already pointed out, you shouldn't do what you're attempting to do here, because it is very likely to create more problems down the road. Find the cause of the issue and fix that instead of trying to handle symptoms. You have been warned.
With that said, the reason why the content of all input files is written to the same output file is because you always specify the same output file. That file should contain only the content of the last input file, though, because you open the file for writing (thus erasing previous content) rather than for appending.
Replace these lines:
Set objFile = objFSO.OpenTextFile(objStartFolder & objFile.Name, 1)
Set outFile = objFSO.OpenTextFile(objStartFolder & "mod.xml", 2, True)
with this:
Set inFile = objFile.OpenAsTextStream
outFilename = objFSO.BuildPath(objStartFolder, objFSO.GetBaseName(objFile) & "_mod.xml")
Set outFile = objFSO.OpenTextFile(outFilename, 2, True)
and also replace the other occurrences of objFile after that with inFile (always avoid changing the value of a loop variable), and the code should do what you expect it to do. But again, be warned that the output may not be valid XML.
I managed to made it working, below is the code I used
Dim objFSO, filePath, objFile, colFiles, s , FName
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set filePath = objFSO.GetFolder("\\demo.US\Modified\")
Set colFiles = filePath.Files
For Each FName in colFiles
set objFile = objFSO.OpenTextFile(FName.Path,1)
set outFile = objFSO.OpenTextFile(LEFT(FName.Path,instr(FName.Path,".xml")-1) &"_mod.xml",2,True)
do until objFile.AtEndOfStream
strContent=objFile.ReadLine
Loop
strContent = Replace(strContent, "encoding=""UTF-8""", "encoding=""windows-1252""")
outFile.WriteLine strContent
outFile.Close
objFile.Close
Next

Read a line from several .txt files and write them into created file

I have a quite simple task.
There is a folder which contains several files with different extensions. I need to make a script which will find all files with .txt extension in this folder, read first line from every file and then write all first lines in newly created file.
For now, I've ended up with something like this:
Option Explicit
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim f, colFiles , objFile
Dim tFolder, tFile
Dim lineToCopy, fileContents
Dim input, output
Set tFolder = fso.GetFolder("C:\Temp")
Set tFile = tFolder.CreateTextFile("test.txt", true)
Set f = fso.GetFolder("D:\Folder")
Set colFiles = f.Files
For Each objFile in colFiles
If LCase(fso.GetExtensionName(objFile.name)) = "txt" Then
Set input = fso.OpenTextFile(LCase(objFile.name))
If Not input.AtEndofStream Then lineToCopy = input.ReadLine
input.close
output = fso.OpenTextFile(tFolder, True)
output.WriteLine lineToCopy
output.close
End If
Next
WScript.sleep 60000000
When activated, .vbs file tells me he couldn't find the file from that line:
Set input = fso.OpenTextFile(LCase(objFile.name))
I suppose that happens because IF LCASE<...> block doesn't understand folder contents as .txt files. Where am I wrong and what is needed to be done to solve that problem?
Kindly yours,
Richard
Use the full .Path of the file for OpenTextFile or get the stream via OpenAsTextStream. Use tFile instead of repeatedly creating output. Delete all the risky/cargo cult fat:
Option Explicit
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim tFile : Set tFile = fso.CreateTextFile(fso.BuildPath(".\", "test.txt"))
Dim oFile
For Each oFile in fso.GetFolder("..\data").Files
If LCase(fso.GetExtensionName(oFile.Path)) = "txt" Then
' Dim input: Set input = fso.OpenTextFile(LCase(oFile.Path))
Dim input: Set input = oFile.OpenAsTextStream()
If Not input.AtEndofStream Then tFile.WriteLine input.ReadLine()
input.Close
End If
Next
tFile.Close
Looks like I've found my own decision:
Option Explicit
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim f, colFiles , objFile
Dim tFolder, tFile
Dim lineToCopy, readFile
Set tFolder = fso.GetFolder("C:\Temp")
Set tFile = tFolder.CreateTextFile("test.txt", true)
Set f = fso.GetFolder("D:\Scripting Games 2008\Beginner")
Set colFiles = f.Files
For Each objFile in colFiles
If LCase(fso.GetExtensionName(objFile.name)) = "txt" Then
REM Preceding passage finds all .txt files in selected folder
Set readFile = objFile.OpenAsTextStream
lineToCopy = ""
Do Until lineToCopy <> "" Or readfile.atEndOfStream
lineToCopy = Trim(readFile.ReadLine)
Loop
REM Extracts first line of the text, if it is not empty
tFile.WriteLine objFile.name & ": " & lineToCopy
End If
Next
Still, thanks for the answers. I've found some interesting solutions which well be of use some time.
Kindly yours,
Richard

How to run windows executable and delete files from sub folders

I need a quick script do two parts.
Run a windows executable
Delete files within a folder and subfolders (*.jpg, *.img).
The first part of the below script works (running the executable) but I am getting stuck on part 2. I get
Cannot use parentheses when calling a sub
The error is on the line with the RecursiveDelete call. I actually cut and pasted that code from another SO question. I have googled the error but still don't understand.
Can anybody know how to get this script working?
Set WshShell = CreateObject("WScript.Shell")
WshShell.Run chr(34) & "C:\Users\acer\Desktop\CT\process.exe" & Chr(34), 0
Set WshShell = Nothing
Dim PicArray(2)
Dim p
PicArray(1) = "*.jpg"
PicArray(2) = "*.img"
For p = 1 To 2
RecursiveDelete ("D:\pictures", PicArray(p))
Next p
Private Sub RecursiveDelete(ByVal Path As String, ByVal Filter As String)
Dim s
For Each s In System.IO.Directory.GetDirectories(Path)
try
RecursiveDelete(s, Filter)
catch dirEx as exception
debug.writeline("Cannot Access " & s & " : " & dirEx.message
end try
Next
For Each s In System.IO.Directory.GetFiles(Path, Filter)
try
System.IO.File.Delete(s)
catch ex as exception
debug.writeline("Cannot delete " & s & " : " & ex.message)
end try
Next
End Sub
Update: Revised answer from Hackoo that works great.
Option Explicit
Dim fso,RootFolder, wshShell
set fso = CreateObject("Scripting.FileSystemObject")
RootFolder = "D:\pictures"
Set RootFolder = fso.GetFolder(RootFolder)
Call RecursiveDelete(RootFolder)
Set WshShell = CreateObject("WScript.Shell")
WshShell.Run chr(34) & "C:\process.exe" & Chr(34), 0
Set WshShell = Nothing
'*****************************************************************************
Function RecursiveDelete(Folder)
Dim File,MyFile,Ext,i,SubFolder
Set Folder = fso.GetFolder(Folder)
For each File in Folder.Files
Set MyFile = fso.GetFile(File)
Ext = Array("iMG","JPG")
For i = LBound(Ext) To UBound(Ext)
If LCase(fso.GetExtensionName(File.name)) = LCase(Ext(i)) Then
MyFile.Delete()
Exit For
end if
Next
Next
For each SubFolder in Folder.SubFolders
Call RecursiveDelete(SubFolder)
Next
End Function
'*****************************************************************************
Try like this way :
Option Explicit
Dim fso,RootFolder
set fso = CreateObject("Scripting.FileSystemObject")
RootFolder = "D:\pictures"
Set RootFolder = fso.GetFolder(RootFolder)
Call RecursiveDelete(RootFolder)
Msgbox "Pictures Cleaned !",vbInformation,"Pictures Cleaned !"
'*****************************************************************************
Function RecursiveDelete(Folder)
Dim File,MyFile,Ext,i,SubFolder
Set Folder = fso.GetFolder(Folder)
For each File in Folder.Files
Set MyFile = fso.GetFile(File)
Ext = Array("jpg","img")
For i = LBound(Ext) To UBound(Ext)
If LCase(fso.GetExtensionName(File.name)) = LCase(Ext(i)) Then
MyFile.Delete()
Exit For
end if
Next
Next
For each SubFolder in Folder.SubFolders
Call RecursiveDelete(SubFolder)
Next
End Function
'*****************************************************************************
Instead of passing the array item into RecursiveDelete, obtain the contents of the array item into a variable within the loop, and pass that variable instead.
Code would be similar to this- did not have a chance to test syntax.
For p = 1 To 2
Dim PicItem
PicItem = PicArray(p)
RecursiveDelete ("D:\pictures", PicItem )
Next p

VB.Net - List files & subfolders from a specified Directory and save to a text document, and sort results

I am working on a project that requires me to search and list all files in a folder that could have multiple sub folders and write it to text documents.
Primarily the file extension i will be searching for is a .Doc, but I will need to list the other files found in said directory as well.
To make things slightly more difficult I want the text documents to be sorted by File type and another by Directory.
I do not know how possible this is, but I have search for methods online, but have as of yet found correct syntax.
Any help will be greatly appreciated.
I write this in the past, should server as a base for your version. I know it's not .NET, still I hope it helps something. It prompts the user for a path to scan, recurses into folders, and writes the file name, path, and owner into a CSV file. Probably really inefficient and slow, but does the job.
Main() ' trickster yo
Dim rootFolder 'As String
Dim FSO 'As Object
Dim ObjOutFile
Dim objWMIService 'As Object
Sub Main()
StartTime = Timer()
If Wscript.Arguments.Count = 1 Then ' if path provided with the argument, use it.
rootFolder = Wscript.Arguments.Item(0)
Else
rootFolder = InputBox("Give me the search path : ") ' if not, ask for it
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ObjOutFile = FSO.CreateTextFile("OutputFiles.csv")
Set objWMIService = GetObject("winmgmts:")
ObjOutFile.WriteLine ("Path, Owner") ' set headers
Gather (rootFolder)
ObjOutFile.Close ' close the stream
EndTime = Timer()
MsgBox ("Done. (ran for " & FormatNumber(EndTime - StartTime, 2) & "s.)")
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function Gather(FolderName)
On Error Resume Next
Dim ObjFolder
Dim ObjSubFolders
Dim ObjSubFolder
Dim ObjFiles
Dim ObjFile
Set ObjFolder = FSO.GetFolder(FolderName)
Set ObjFiles = ObjFolder.Files
For Each ObjFile In ObjFiles 'Write all files to output files
Set objFileSecuritySettings = _
objWMIService.Get("Win32_LogicalFileSecuritySetting='" & ObjFile.Path & "'")
intRetVal = objFileSecuritySettings.GetSecurityDescriptor(objSD)
If intRetVal = 0 Then
owner = objSD.owner.Domain & "\" & objSD.owner.Name
ObjOutFile.WriteLine (ObjFile.Path & ";" & owner) ' write in CSV format
End If
Next
Set ObjSubFolders = ObjFolder.SubFolders 'Getting all subfolders
For Each ObjFolder In ObjSubFolders
Set objFolderSecuritySettings = _
objWMIService.Get("Win32_LogicalFileSecuritySetting='" & ObjFile.Path & "'")
intRetVal = objFolderSecuritySettings.GetSecurityDescriptor(objSD)
If intRetVal = 0 Then
owner = objSD.owner.Domain & "\" & objSD.owner.Name
ObjOutFile.WriteLine (ObjFolder.Path & ";" & owner) ' write in CSV format
End If
Gather (ObjFolder.Path)
Next
End Function

Resources