remove nul characters from text file using vbs - vbscript

I have text files that are approximately 6MB in size. There are some lines that contain the NULL (Chr(0))character that I would like to remove.
I have two methods to do this: using Asc()=0 but this takes approximately 50s to complete, the other method uses InStr (line, Chr(0)) =0 (fast ~ 4sec)but the results remove vital info from the lines which contain the NULL characters.
First line of text file as example:
##MMCIBN.000NULL7NULL076059NULL7653NULL1375686349NULL2528NULL780608NULL10700NULL\NULL_NC_ACT.DIR\CFG_RESET.INI
First method (works but VERY slow)
function normalise (textFile )
Set fso = CreateObject("Scripting.FileSystemObject")
writeTo = fso.BuildPath(tempFolder, saveTo & ("\Output.arc"))
Set objOutFile = fso.CreateTextFile(writeTo)
Set objFile = fso.OpenTextFile(textFile,1)
Do Until objFile.AtEndOfStream
strCharacters = objFile.Read(1)
If Asc(strCharacters) = 0 Then
objOutFile.Write ""
nul = true
Else
if nul = true then
objOutFile.Write(VbLf & strCharacters)
else
objOutFile.Write(strCharacters)
end if
nul = false
End If
Loop
objOutFile.close
end function
The output looks like this:
##MMCIBN.000
7
076059
7653
1375686349
2528
780608
10700
\
_NC_ACT.DIR\CFG_RESET.INI
Second method code:
filename = WScript.Arguments(0)
Set fso = CreateObject("Scripting.FileSystemObject")
sDate = Year(Now()) & Right("0" & Month(now()), 2) & Right("00" & Day(Now()), 2)
file = fso.BuildPath(fso.GetFile(filename).ParentFolder.Path, saveTo & "Output " & sDate & ".arc")
Set objOutFile = fso.CreateTextFile(file)
Set f = fso.OpenTextFile(filename)
Do Until f.AtEndOfStream
line = f.ReadLine
If (InStr(line, Chr(0)) > 0) Then
line = Left(line, InStr(line, Chr(0)) - 1) & Right(line, InStr(line, Chr(0)) + 1)
end if
objOutFile.WriteLine line
Loop
f.Close
but then the output is:
##MMCIBN.000\CFG_RESET.INI
Can someone please guide me how to remove the NULLS quickly without losing information. I have thought to try and use the second method to scan for which line numbers need updating and then feed this to the first method to try and speed things up, but quite honestly I have no idea where to even start doing this!
Thanks in advance...

It looks like the first method is just replacing each NULL with a newline. If that's all you need, you can just do this:
Updated:
OK, sounds like you need to replace each set of NULLs with a newline. Let's try this instead:
strText = fso.OpenTextFile(textFile, 1).ReadAll()
With New RegExp
.Pattern = "\x00+"
.Global = True
strText = .Replace(strText, vbCrLf)
End With
objOutFile.Write strText
Update 2:
I think the Read/ReadAll methods of the TextStream class are having trouble dealing with the mix of text and binary data. Let's use an ADO Stream object to read the data instead.
' Read the "text" file using a Stream object...
Const adTypeText = 2
With CreateObject("ADODB.Stream")
.Type = adTypeText
.Open
.LoadFromFile textFile
.Charset = "us-ascii"
strText = .ReadText()
End With
' Now do our regex replacement...
With New RegExp
.Pattern = "\x00+"
.Global = True
strText = .Replace(strText, vbCrLf)
End With
' Now write using a standard TextStream...
With fso.CreateTextFile(file)
.Write strText
.Close
End With

I tried this method (update2) for reading a MS-Access lock file (Null characters terminated strings in 64 byte records) and the ADODB.Stream didn't want to open an already in use file. So I changed that part to :
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFile(Lfile)
z = f.Size
set ts = f.OpenAsTextStream(ForReading, 0) 'TristateFalse
strLog = ts.Read(z)
ts.Close
set f = nothing
' replace 00 with spaces
With New RegExp
.Pattern = "\x00+"
.Global = True
strLog = .Replace(strLog, " ")
End With
' read MS-Access computername and username
for r = 1 to len(strLog) step 64
fnd = trim(mid(strLog,r, 32)) & ", " & trim(mid(strLog,r+32, 32)) & vbCrLf
strRpt = strRpt & fnd
next

Related

Skip some text from line

I need to remove some text from lines:
strdir = "C:\texto.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFile = fso.OpenTextFile(strdir)
Dim arrTxt()
k = 0
Do Until objFile.AtEndOfStream
z = (k+1)
ReDim Preserve arrTxt(z)
line = objFile.ReadLine
arrTxt(k) = line
k = z
Loop
print Join(arrTxt, ",")
print (UBound(arrTxt) + 1)
My text file texto.txt:
name=test
correo=test#test.tst
I want remove "name=" and "correo=".
#Cid showcased how you can use the power of Split/Join to achieve what you want. I am going to demonstrate how you can harness the power of RegEx to achieve similar result without having to read one line at a time.
Assuming your text file looks like this
strdir = "C:\texto.txt"
Set objFSO = CreateObject("Scripting.filesystemobject")
Set objFile = objFSO.OpenTextFile(strdir)
strContent = objFile.ReadAll
objFile.Close
msgbox RemoveLines(strContent)
Function RemoveLines(str)
Dim objRegEx
Set objRegEx = New RegExp
With objRegEx
.Global = True
.Pattern = "^name=.*\n|^correo=.*\n"
.Multiline = True
End With
RemoveLines = objRegEx.Replace(str, "")
End Function
Output
I'd split each lines using = as delimiter and then, I'd check if the first element is name or correo.
strdir = "C:\texto.txt"
Set fso = createobject("Scripting.filesystemobject")
Set objFile = fso.OpenTextFile(strdir)
Dim arrTxt()
k = 0
Do until objFile.AtEndOfStream
z = (k+1)
ReDim preserve arrTxt(z)
line = objFile.ReadLine
myArray = Split(line, "=")
If (Not ((UBound(myArray) > 0) AND (myArray(0) = "name" OR myArray(0) = "correo"))) Then
arrTxt(k) = line
k = z
End If
loop
print Join(arrTxt,",")
print (Ubound(arrTxt) + 1)
With vba - The initial idea is to make the code understandable for a human - the code has the following 3 tasks:
Read from a file and save the input as a string;
Manipulate the string (e.g. replace the name= and correo=;
Write the manipulated string to a new file;
All these actions are noticeable in the TestMe():
Sub TestMe()
Dim readTxt As String
Dim filePath As String: filePath = "C:\text.txt"
readTxt = ReadFromFile(filePath)
readTxt = Replace(readTxt, "name=", "")
readTxt = Replace(readTxt, "correo=", "")
WriteToFile filePath, readTxt
End Sub
Once the bone above is ready, the two functions ReadFromFile and WriteToFile are quite handy:
Public Function ReadFromFile(path As String) As String
Dim fileNo As Long
fileNo = FreeFile
Open path For Input As #fileNo
Do While Not EOF(fileNo)
Dim textRowInput As String
Line Input #fileNo, textRowInput
ReadFromFile = ReadFromFile & textRowInput
If Not EOF(fileNo) Then
ReadFromFile = ReadFromFile & vbCrLf
End If
Loop
Close #fileNo
End Function
Sub WriteToFile(filePath As String, text As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oFile As Object
Set oFile = fso.CreateTextFile(filePath)
oFile.Write text
oFile.Close
End Sub

Read file names into an array or dictionary for use as a user input

I would like to have a script that reads a specific folder and extracts the base file names, removes the last two characters and then uses the result to populate the text of an inputbox. The user then selects from the given options and the remainder of the script searches and replaces text in a second folder with the selected text.
Example file names in the initial target folder:
ABFA1
ABFA3
ABFA4
HVA1
HVA3
HVA4
ITALA1
ITALA3
ITALA4
Obviously, once the last 2 characters are removed, I am left with duplicates which I will need to remove.
Here is part of the script I have so far:
Set objFSO = CreateObject("Scripting.FileSystemObject")
strFilePath = objFSO.BuildPath(objFSO.GetAbsolutePathName("."), "\dwgs\logos")
If Not objFSO.FolderExists(strFilePath) Then
wscript.echo("Folder does not exist, script exiting")
wscript.quit
End if
'
Set objFolder = objFSO.GetFolder (strFilePath)
For Each objFile In objFolder.Files
strFile = objFSO.GetBaseName(objFile.Name)
strFile = LEFT(strFile, (LEN(strFile)-2))
' wscript.echo(strFile)
Next
'delete all duplicate files names and add result to dictionary (or array?)
'create an inputbox and present a number of choices populated by the dictionary/array
user1 = InputBox("Select a Logo:"&(chr(13))&(chr(13))&(*array/dict*)), "Logo Replacement Script")
' Set arguments
strFilePath2 = objFSO.BuildPath(objFSO.GetAbsolutePathName("."), "\dwgs")
FindString = "dwgs\logos\"
ReplaceStringWith = "dwgs\logos\"&(user1)
' Find and replace function
I am able to get the base file names with the last 2 characters removed, but I dont know how to weed out the duplicates and then use the result in an inputbox? (I'm imagining text within the inputbox of a number followed by a choice and the user enters the number to signify which option to use)
My first thought was to use an array, but after some reading, it would seem a dictionary approach might be better. Unfortunately, I haven't been able to figure out how to incorporate it into the script.
Any help would be much appreciated.
Updated script incorporating input from Ekkehard:
Set objFSO = CreateObject("Scripting.FileSystemObject")
strFilePath = objFSO.BuildPath(objFSO.GetAbsolutePathName("."), "\dwgs\logos")
'
Function ShowFilesInFolder(strFolderPath)
Set oFolder = objFSO.GetFolder(strFolderPath)
Set oFileCollection = oFolder.Files
For Each oTempFile in oFileCollection
strTemp = strTemp & oTempFile.name
strTemp = LEFT(strTemp, (LEN(strTemp)-6))
Next
ShowFilesInFolder = strTemp
End Function
x = ShowFilesInFolder(strFilePath)
'
Function mkDic(aK, aV)
Dim tmp : Set tmp = CreateObject("Scripting.Dictionary")
Dim i
For i = 0 To UBound(aK)
tmp(aK(i)) = aV(i)
Next
Set mkDic = tmp
End Function
'
Dim a : a = Split (x)
WScript.Echo Join(mkDic(a, a).Keys)
For some reason I cant get the mkDic Function to split the input from the ShowFilesInFolder Function?
Is there an easier way to go about it than what I have come up with?
The VBScript tool for uniqueness is The Dictionary. This demo (cf. here)
Option Explicit
' based on an Array 2 Dictionary function from
' !! https://stackoverflow.com/a/45554988/603855
Function mkDic(aK, aV)
Dim tmp : Set tmp = CreateObject("Scripting.Dictionary")
Dim i
For i = 0 To UBound(aK)
' tmp(aK(i)) = aV(i)
tmp(Mid(aK(i), 1, Len(aK(i)) - 2)) = aV(i)
Next
Set mkDic = tmp
End Function
Dim a : a = Split("ABFA1 ABFA3 ABFA4 HVA1 HVA3 HVA4 ITALA1 ITALA3 ITALA4")
WScript.Echo Join(a)
WScript.Echo Join(mkDic(a, a).Keys), "=>", Join(mkDic(a, a).Items)
output:
cscript 45590698.vbs
ABFA1 ABFA3 ABFA4 HVA1 HVA3 HVA4 ITALA1 ITALA3 ITALA4
ABF HV ITAL => ABFA4 HVA4 ITALA4
shows, how to de-duplicate an array and how to stringify the (unique) keys for concatenating into a prompt.
I managed to get a working script, but couldn't figure out how to do it without using a couple of temporary text files to pass the data on.
I thought I would post the code in case it may be of help to someone.
Const ForReading = 1, ForWriting = 2, ForAppending = 8, N = 0
Set fso = CreateObject("Scripting.FileSystemObject")
strFilePath = fso.BuildPath(fso.GetAbsolutePathName("."), "\dwgs\logos")
If Not fso.FolderExists(strFilePath) Then
wscript.echo("The LOGO Folder Does Not Exist - Exiting Script")
wscript.quit
End if
'
Set f = fso.OpenTextFile("xtempLogos.txt", ForWriting, True)
Set objShell = CreateObject ("Shell.Application")
Set objFolder = objShell.Namespace (strFilePath)
For Each strFileName in objFolder.Items
a = objFolder.GetDetailsOf (strFileName, N)
a = LEFT(a, (LEN(a)-6))
f.Writeline (a)
Next
f.Close
'
Set f = fso.OpenTextFile("xtempLogos.txt", ForReading)
TheFile = f.ReadAll
f.Close
'
Function mkDic(aK, aV)
Dim tmp : Set tmp = CreateObject("Scripting.Dictionary")
Dim i
For i = 0 To UBound(aK)
tmp(aK(i)) = aV(i)
Next
Set mkDic = tmp
End Function
'
Set f = fso.OpenTextFile("xtempLogos.txt", ForWriting, True)
Dim a : a = Split(TheFile,vbcrlf)
a = Join(mkDic(a, a).Keys)
f.Writeline (a)
f.Close
'
Set f = fso.OpenTextFile("xtempLogos2.txt", ForWriting, True)
Set f = fso.OpenTextFile("xtempLogos.txt", ForReading)
theFile = f.ReadAll
number = 1
myArray = Split(theFile)
for i = 0 to Ubound(MyArray)-1
Set f = fso.OpenTextFile("xtempLogos2.txt", ForAppending, True)
If number < 10 then f.Writeline (number) & ".........." & myArray(i)
If number >=10 then f.Writeline (number) & "........." & myArray(i)
f.Writeline ""
Set f = fso.OpenTextFile("xtempLogos.txt", ForReading, True)
number=number+1
Next
f.Close
'
Set f = fso.OpenTextFile("xtempLogos2.txt", ForReading)
TheFile = f.ReadAll
f.Close
'
user1 = InputBox("WHICH LOGO DO YOU WANT TO ADD?"&(chr(13))&(chr(13))&(chr(13))& (theFile), "Add Logo Script", 11)
choice = (user1) - 1
wscript.echo myArray(choice)
'
Set f = fso.GetFile("xtempLogos.txt")
f.Delete
Set f = fso.GetFile("xtempLogos2.txt")
f.Delete

I want to search for the particular word and then after that word on each line i want to add ; in the start

Using below code I was able to add ; in the start of each line but the I want to add ; after a particular word is found e.g. [Abc]. How to do this using VBScript?
Const ForReading=1
Const ForWriting=2
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set f = objFSO.OpenTextFile("D:\sam.txt", ForReading)
Do Until f.AtEndOfStream
strText = f.ReadLine
If Len(strText) = 0 Then
blnFound = True
MsgBox "blank line found"
strText = vbNewLine & strText
strContents = strContents & strText & vbCrlf
Else
strText = ";" & strText
strContents = strContents & strText & vbCrlf
End If
Loop
f.Close
Set f = objFSO.OpenTextFile("D:\sam.txt", Forwriting)
f.WriteLine strContents
f.Close
Sam.txt is containing some lines, e.g.
Hi, need help
This is a sample text file
[Abc]
How are you
Hope you are doing well!
So I want the output sam.txt file should have below data inside it:
Hi, need help
This is a sample text file
[Abc]
;How are you
;Hope you are doing well!
So, basically, you have an INI-style file and want the entries in a particular section commented. That can be achieved like this:
filename = "D:\sam.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
txt = Split(fso.OpenTextFile(filename).ReadAll, vbNewLine)
disable = False
For i = 0 To UBound(txt)
If Left(txt(i), 1) = "[" Then
If txt(i) = "[Abc]" Then
disable = True
Else
disable = False
End If
End If
If disable Then txt(i) = ";" & txt(i)
Next
fso.OpenTextFile(filename, 2).Write Join(txt, vbNewLine)
Try this
Option Explicit
Dim FSO ' Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim ReadTxtFile, WriteTxtFile ' Object
Dim TextLine, TextLineToWrite ' String
Dim AddStr' bool
' Open both text file in the same time
Set ReadTextFile = FSO.OpenTextFile("Sam.txt", 1) ' Open file to read
Set WriteTextFile = FSO.OpenTextFile("Sam_new.txt", 2, True) ' Open file to write
' Do read file as normal but add a switch
' Write original text line to text file while switch is disabled
' Add str to the text line and write once switch is trigger
AddStr = False ' Add str disabled
Do Until ReadTextFile.AtEndOfStream ' Start Read
Textline = ReadTextFile.Readline
If AddStr = True Then ' If add str enabled
TextLineToWrite = ";" & Textline ' Add string
Else ' if add str disabled
TextLineToWrite = Textline ' write original line
End If
If Trim(Textline) = "[ABC]" Then ' If indicator read
AddStr = True ' add str write
End if
WriteTextFile.WriteLine TextLineToWrite ' Write file when each line is read
Loop
ReadTextFile.Close
WriteTextFile.Close
msgbox "Done"

VBscript - Hot to Write to a specific blank line?

I need to insert a strText to line 14 in a template.txt file. Line 14 will always be blank before writing (sort of like appending I guess).
What I really need is to copy line 21 to line 14. Not sure what is the easier method to achieve this?
Here is what I have so far but not working. Below code is the template.txt.
Dim objFSO : Set objFSO = CreateObject("Scripting.FileSystemObject")
DIM Infile : Infile = "C:\template.txt"
Set tempFile = objFSO.OpenTextFile (Infile)
strText = tempFile.ReadAll
tempFile.Close
strNewText = Replace(strText, "","Channel_LandWaterMask = 3.0")
Set tempFile = objFSO.OpenTextFile (Infile, 2)
tempfile.Writeline 14, strNewText ‘(How would I write this???)
tempFile.Close
Here is the template.txt:
; Resample INF script for
; Section_YY XX_ZZZZ
[Source]
Type = MultiSource
NumberOfSources = 2
[Source1]
Type = GeoTIFF
Layer = Imagery
SourceDir = "S:\XX\Section_YY\Images"
SourceFile = "XX_ZZZZ_CC.tif"
Variation = DAY
[Source2]
Type = GeoTIFF
Layer = Imagery
SourceDir = "S:\XX\Section_YY\Images"
SourceFile = "XX_ZZZZ_LM.tif"
Variation = Night
Channel_LandWaterMask = 3.0
[Source3]
Type = GeoTIFF
Layer = None
SourceDir = "S:\XX\Section_YY\Images"
SourceFile = "XX_ZZZZ_WM.tif"
SamplingMethod = Gaussian
[Destination]
DestDir = "S:\2_Output\Section_YY"
DestBaseFileName = "XX_ZZZZ"
DestFileType = BGL
LOD = Auto
UseSourceDimensions = 1
CompressionQuality = 85
Take a look at the below example:
sContent = ReadTextFile("C:\template.txt", 0)
aContent = Split(sContent, vbCrLf)
aContent(13) = aContent(20) & vbCrLf & aContent(13)
sContent = Join(aContent, vbCrLf)
WriteTextFile sContent, "C:\template.txt", 0
Function ReadTextFile(sPath, lFormat)
' lFormat -2 - System default, -1 - Unicode, 0 - ASCII
With CreateObject("Scripting.FileSystemObject").OpenTextFile(sPath, 1, False, lFormat)
ReadTextFile = ""
If Not .AtEndOfStream Then ReadTextFile = .ReadAll
.Close
End With
End Function
Sub WriteTextFile(sContent, sPath, lFormat)
' lFormat -2 - System default, -1 - Unicode, 0 - ASCII
With CreateObject("Scripting.FileSystemObject").OpenTextFile(sPath, 2, True, lFormat)
.Write sContent
.Close
End With
End Sub
Note that it inserts the content of the line 21 before the line 14, thus preserving newline, since the content of the line 14 are newline chars. If you want just replace, then use aContent(13) = aContent(20) instead of aContent(13) = aContent(20) & vbCrLf & aContent(13).
Do Until Inp.AtEndOfStream
Count=Count + 1
Line=Inp.readline
If Count = 14 then
outp.writeline "My line 14"
Else
outp.writeline Line
End If
Loop
Is the pattern for your type of problem. Read a line, make a decision, write something.

subscript out of range error in vbscript

Can someone look at the below script and tell me why it's throwing this error subscript out of range error in vbscript ..In the text file there are two entries it writes to the file correctly but then it throws an error while exiting the loop so it never calls the other function..I think it's trying to run 3 times but there are just 2 entries in the text file
The text file is in this format
Format.css Shared
Design.css Shared
Dim strInputPath1
Dim txsInput1,txsOutput
Dim FSO
Dim Filename
Set FSO = CreateObject("Scripting.FileSystemObject")
strOutputPath = "C:\txt3.txt"
Set txsOutput = FSO.CreateTextFile(strOutputPath)
Set re = New RegExp
re.Pattern = "\s+"
re.Global = True
Set f = FSO.OpenTextFile("C:\Users\spadmin\Desktop\Main\combination.txt")
Do Until f.AtEndOfStream
tokens = Split(Trim(re.Replace(f.ReadLine, " ")))
extension = Split(tokens(0),".")
strInputPath1 = "C:\inetpub\wwwroot\Test\files\" & tokens(1) & "\" & extension(1) & "\" & tokens(0)
Set txsInput1 = FSO.OpenTextFile(strInputPath1, 1)
WScript.Echo strInputPath1
txsOutput.Writeline txsInput1.ReadAll
Loop
WScript.Echo "Calling"
txsInput1.Close
txsOutput.Close
f.Close
Call CreateCSSFile()
''''''''''''''''''''''''''''''''''''
' Merge Css Files
''''''''''''''''''''''''''''''''''''
Sub CreateCSSFile()
WScript.Echo "Called"
Dim FilenameCSS
Dim strInputPathCSS
Dim txsInputCSS,txsOutputCSS
Dim FSOCSS
Set FSOCSS = CreateObject("Scripting.FileSystemObject")
strOutputPathCSS = "C:\txt4.txt"
Set txsOutputCSS = FSOCSS.CreateTextFile(strOutputPath)
Set re = New RegExp
re.Pattern = "\s+"
re.Global = True
Set fCSS = FSOCSS.OpenTextFile("C:\Users\spadmin\Desktop\TestingTheWebService\combination.txt")
Do Until fCSS.AtEndOfStream
tokensCSS = Split(Trim(re.Replace(fCSS.ReadLine, " ")))
extensionCSS = Split(tokensCSS(0),".")
strInputPathCSS = "C:\inetpub\wwwroot\EpsShared\c\" & tokensCSS(1) & "\" & extensionCSS(1) & "\" & tokensCSS(0)
Set txsInputCSS = FSOCSS.OpenTextFile(strInputPathCSS, 1)
txsOutputCSS.Writeline txsInputCSS.ReadAll
Loop
fCSS.Close
txsInputCSS.Close
txsOutputCSS.Close
Set FSOCSS = Nothing
End Sub
If your file contains trailing blank lines, applying Split() may return arrays with less than 2 elements. In that case token(1) should throw a 'subscript out of range' error.
You should always check, if Split() workes as expected:
tokens = Split(Trim(re.Replace(f.ReadLine, " ")))
If 1 = UBound(tokens) Then
extension = Split(tokens(0),".")
If 1 = UBound(extension) Then
strInputPath1 = "..." & tokens(1) & "..."
Else
... parse error ...
End If
Else
... parse error or just trailing blank lines? ...
End If

Resources